commit ccd691edd0ff3a03afa229bdf7c3c996b2b1505e Author: gansito05 Date: Fri Oct 2 14:14:47 2026 -0500 Initial Lime window manager diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9eca954 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*.fasl +*.dfsl +*.lx64fsl +*.dx64fsl +*.x86f +*.log +/.cache/ diff --git a/README.md b/README.md new file mode 100644 index 0000000..365e23d --- /dev/null +++ b/README.md @@ -0,0 +1,313 @@ +# Lime + +Lime is an experimental **X11 window manager written in Common Lisp**, organized +around what you're doing: work, a project, a game, or whatever else needs its own +set of windows. + +Keep related windows in a named **activity**, show only what you need, and save +useful arrangements as optional **views**. Each monitor can switch activities +independently. Configure and extend Lime in Lisp, with a live REPL available for +development. + +Lime is undergoing real daily-use testing on Linux with SBCL. It manages a real +desktop, but remains a young project: compatibility, recovery, and interaction +details are still being refined. Start in Xephyr and keep a known-good session +available before trying it as your main window manager. + +## The workflow + +### Activities hold your windows + +Create an activity such as `work`, `lime`, or `chill`, then open the applications +you need. There is no fixed activity count and no requirement to save a view. +New activities start with a blank working arrangement. + +New activities are **portable**. Select one on a monitor—called a **Head** in +Lime—and its current arrangement comes there, including unsaved edits. If it +is already displayed elsewhere, the two monitors swap their arrangements. +If it was inactive, only the chosen monitor changes. There is no empty +monitor-specific copy to hunt through. + +Need more room? `Super-y → a → e` explicitly extends the current activity onto +another monitor. Its portions can then switch away and return independently. +New portions start empty; windows are never duplicated or gathered implicitly. +This choice persists even if a portion becomes empty. `Super-y → a → p` makes +it portable again once the other portions are empty and no longer displayed. + +Hide a window when you don't need it in the current arrangement. It stays in +the activity, available from the window picker. Hiding is distinct from monocle: +monocle cycles through its participating windows, while hidden windows sit out. + +### Views are optional checkpoints + +Suppose your `lime` activity contains an editor, documentation browser, two +terminals, and a test application. Save a `code` view showing the editor and a +terminal; save a `debug` view showing the test application and its logs. + +These are saved arrangements of the activity's windows, not separate window +buckets. Recalling a view restores its requested windows, layout, and focus on +one Head. Editing the arrangement does not overwrite the checkpoint; updating +a saved view is explicit. New windows are not added to older checkpoints +automatically. Deleting a view does not close its windows or delete the activity. + +An activity works just fine with no saved views at all. The bar shows activity +names, with the current one highlighted; checkpoint actions live in the menu. +For coordinated multi-monitor recalls, a **Viewset** saves a mapping of Heads +to views and applies it as one checked transition. + +### One window, one place + +A real window can appear on only one Head at a time. Internally, a **lease** +records which current arrangement owns its display. If a requested window is +already in use elsewhere, Lime asks whether to open without it or move it here. +A saved view cannot be mounted on two Heads simultaneously. + +Windows normally belong to one home activity. You can move them to another, or +make them **shared** so any activity can request them—useful for a music player. +Sharing does not duplicate a window or make it appear everywhere. Making it +private again keeps it in the activity where you're using it, preserves its +placement, and removes references from other activities, including their saved +views. That change requires confirmation. + +## What works today + +- **Tiling and floating:** master/stack by default, monocle, per-window floating, + tiled reordering and sizing, mouse move/resize, configurable new-window/focus + policy, borders, and gaps. A sole visible tile has no gaps or border; floats + retain their borders. Manual tiling trees remain available through Lisp and + saved views, but are excluded from the everyday layout cycle. +- **Independent monitors:** RandR discovery, portable activity swaps and explicit + multi-Head arrangements, + numbered activity/view navigation, and window transfers that follow the moved + window with focus. Private cross-activity transfers ask before changing home + membership. Display changes offer an explicit reconciliation plan. +- **Everyday client handling:** close requests, focus protocols, size hints, + floating dialogs and fixed-size startup windows, fullscreen, and quiet + attention indicators. Compatibility covers a selected ICCCM/EWMH subset. +- **Keyboard and mouse UI:** a clickable per-Head bar, a which-key-style command + dropdown, searchable pickers, and a fuzzy PATH launcher. The launcher caches + executable discovery; shortcut-to-menu keyboard handoff preserves rapid + follow-up typing, including during a cold refresh. +- **Configurable presentation:** Pango/Cairo text with Unicode/font fallback, + colors, and session-local cursor themes. Optional music, volume, and clock providers + publish data to Lisp formatters and click actions. Music/audio updates use + subscriptions; the clock wakes on minute boundaries. +- **Live development and saved desks:** reloadable Lisp configuration, + function-level source reloads through SLY/Slynk, supervised error recovery, + and session autosave. A Lime-only restart can reconnect surviving X windows + to their arrangements. + +## Try it safely in Xephyr + +Use a nested X server first. **Do not start Lime on a display already managed +by another window manager.** + +You need: + +- Linux/X11, SBCL, ASDF, and Quicklisp loaded by your SBCL startup file. +- Xephyr for this nested test, and a test client such as `xterm`. +- Native Cairo, Pango/PangoCairo, GLib, and GObject libraries, plus suitable fonts. +- Slynk available to ASDF for `lime/dev` (normally supplied through SLY or your + Lisp dependency setup). Optional libXcursor enables cursor themes. + +From the checkout, in an SBCL REPL, register the local systems and load the +development dependencies once: + +```lisp +(require :asdf) +(asdf:load-asd (truename "lime.asd")) +(ql:quickload "lime/dev") +``` + +The ASDF definitions also declare CLX, Babel, CFFI, Bordeaux Threads, and usocket +(0.8.8 or newer). If Slynk is not available through Quicklisp, make SLY's Slynk +ASDF system discoverable before loading `lime/dev`. + +Then, from a terminal in your existing graphical session: + +```sh +./scripts/run-xephyr-dev --no-config --no-session --repl-port 4006 +``` + +This starts Xephyr on `:99` with a blank `Scratch` activity, Lime's starter +bindings, no personal config, and no session restore/autosave. It uses port +`4006` here to avoid the usual +development REPL on `4005`. Choose another free display/port if needed: + +```sh +./scripts/run-xephyr-dev --help +``` + +Click inside Xephyr and use its `Ctrl-Shift` input-grab toggle when you want +shortcuts to reach the nested session instead of your host WM. Release the grab +with the same toggle. To create test windows from a host terminal: + +```sh +DISPLAY=:99 xterm +DISPLAY=:99 xterm +``` + +Quit Lime with `Super-Shift-q`, or stop the runner with Ctrl-C in its host +terminal. The runner tears down its nested server; windows in that test server +will close. + +Nested X separates displays, **not application profiles or desktop services**. +A browser/editor may reuse an existing process on your main desktop, and audio +or D-Bus services may be shared. Use simple test clients or explicitly isolated +application profiles when needed. + +### Starter controls + +These are the bundled defaults, not requirements for your personal keymap. +`Super` means Mod4, usually the Windows/logo key. The `st` and Waterfox launch +bindings require those programs; `Super-p` can launch other installed programs. + +| Binding | Action | +| --- | --- | +| `Super-p` | Fuzzy-search PATH programs and launch one | +| `Super-y` | Open the which-key command menu | +| `Super-Shift-Return` / `Super-b` | Launch `st` / Waterfox | +| `Super-t` / `Super-h` | Focus next / previous visible window | +| `Super-Shift-t` / `Super-Shift-h` | Reorder the focused tiled window | +| `Super-Return` | Promote the focused tile to master | +| `Super-Tab` | Cycle master/stack and monocle | +| `Super-d` / `Super-n` | Shrink / grow the master area | +| `Super-Space` / `Super-f` | Toggle floating / fullscreen | +| `Super-i` / `Super-Shift-i` | Show hidden/shared windows / hide focused window | +| `Super-1…9,0` | Select activity positions 1–10 in bar order | +| `Super-Shift-1…9,0` | Select saved-view slots 1–10 within the activity | +| `Super-e` / `Super-Shift-e` | Focus next Head / move window there and follow | +| `Super-Shift-s` | Choose a saved view to update, with confirmation | +| `Super-Shift-c` / `Super-Shift-q` | Close focused window / quit Lime | + +Super + left/right mouse drag moves/resizes a float; Super + middle click +toggles floating. Activity numbers close gaps after deletion; view slots stay +stable. The first ten shortcuts are not a limit on how many you can create. + +In the command menu, press a shown key or click its entry. `+` marks a submenu; +Backspace goes up, Space/Tab opens search, and Esc closes. Useful paths include +`a → n` to create an activity, `v → s` to save a view, `v → o` to recall one, +`w → m` to move a window to another activity, and `w → s` to share/make private. + +## Make it yours + +Configuration is a user-owned Lisp file, separate from both Lime's source and +saved session state. For example, save this as `~/.config/lime/config.lisp` to +keep the starter map but use `xterm` and add a live config-reload binding: + +```lisp +(in-package #:cl-user) + +(lime.config:defconfiguration my-lime + (:options :default-keybindings t :default-layout :master-stack) + (:command terminal + :label "Terminal" :key #\t + :action (lambda (backend) + (lime.x11:backend-launch-program backend '("xterm")))) + (:bind #\Return terminal :modifiers '(:mod-4 :shift)) + (:command reload-config + :label "Reload configuration" + :action #'lime.config:reload-configuration) + (:bind #\r reload-config :modifiers '(:mod-4 :shift))) +``` + +Run the Xephyr script without `--no-config` to load that file when it exists, +or select one with `--config PATH`. Without `--no-session`, developer sessions +autosave to the XDG state directory in separate files per display. Explicit +`--session-file PATH` is also supported. + +The [configuration guide](docs/configuration.md) covers commands, bindings, +layout policies, window rules, fonts, borders/gaps, bar colors, cursor themes, +and optional status providers. Configuration reload preserves the current desk. + +## Develop while it runs + +The separate `lime/dev` system runs X events on one owner thread and exposes a +loopback-only Slynk REPL. Connect SLY to `127.0.0.1:4006` for the example above +(the runner's default is `4005`). Serialize live backend work through its API: + +```lisp +(lime.dev:with-development-backend (backend) + (lime.x11:backend-status backend)) + +(lime.dev:reload-development-configuration) +(lime.dev:reload-development-code) +``` + +Ordinary function-level edits can reload without replacing your activities or +windows. Structure changes remain an explicit restart boundary. Unexpected +event-loop errors pause dispatch, release input grabs, and preserve the control +REPL for inspection and explicit recovery. See the +[development guide](docs/development.md) before running on a real X session. + +## Current boundaries + +- **X11 only.** Lime is not a Wayland compositor or a complete desktop environment. +- **Partial ICCCM/EWMH coverage.** There is no conventional numbered-desktop + emulation for external pagers. External docks can be mapped, but their strut + reservations do not yet define Lime's work areas. Hotplug reconciliation is + explicit rather than automatic. +- **Views capture arrangements, not applications.** Persistence reconnects + verified surviving windows on the same X server. It does not relaunch programs + or restore browser/terminal contents after logout or reboot. +- **Some interfaces are still low-level.** There is no interactive layout + designer, dedicated all-floating layout, or per-window titlebar decoration. + Manual trees remain an advanced API. Window rules style new clients rather + than automatically assigning activities or taking leases. +- **Application cursor behavior varies.** Explicit cursor config is published + to the X session, but some apps need reopening or override the theme. Lime + respects an existing XSETTINGS manager and does not rewrite toolkit configs. +- **Lisp configuration is trusted code.** Load only configuration you trust; + validation/rollback of WM settings cannot undo arbitrary Lisp side effects. + Keep backups of important session files before structural upgrades. + +## Tests + +The model, UI state machine, persistence, and adapter-policy tests use ASDF and +FiveAM without a running X server. Adapter font tests still require the native +text libraries. From an SBCL REPL in the checkout: + +```lisp +(require :asdf) +(asdf:load-asd (truename "lime.asd")) +(ql:quickload '("lime/test" "lime/ui/test" "lime/persistence/test" + "lime/x11/test" "lime/dev/test")) +(dolist (system '("lime" "lime/ui" "lime/persistence" "lime/x11" "lime/dev")) + (asdf:test-system system)) +``` + +Inspect FiveAM's pass/fail summary, not just the Lisp process exit status. + +Real-X smoke tests create and tear down their own Xvfb servers; they do not use +your current display. With Xvfb and the Lisp dependencies installed, run one or +all from the checkout: + +```sh +sbcl --non-interactive --load test/x11-launcher-smoke.lisp + +for smoke in test/x11-*-smoke.lisp; do + sbcl --non-interactive --load "$smoke" || break +done +``` + +These cover burst keyboard input, clickable menus, numbered navigation, +membership and monitor moves, floating gestures, appearance, fonts/cursors, +status subscriptions, attention, persistence, and fault recovery. The font +tests need Japanese/emoji fonts for their samples; cursor tests additionally +need Adwaita and test-only libXfixes. The session-settings smoke test also needs +Python 3 with PyGObject and GTK 3. Status tests use fake services rather than +controlling your real music or audio. + +## Further reading + +- [Configuration](docs/configuration.md): user policy, styling, commands, and providers. +- [Live development](docs/development.md): SLY, reloads, restarts, and error recovery. +- [Persistence](docs/persistence.md): saved state, window identity, and migration limits. +- [Attention](docs/attention.md): urgency, acknowledgement, and explicit visits. +- [Model](docs/model.md): activities, views, presentations, leases, and invariants. +- [Architecture](docs/architecture.md): boundaries between the model, X11, commands, and UI. +- [X11/REPL walkthrough](docs/xephyr-demo.md): detailed nested-server exercises. + +The current focus is daily-use polish and robustness: fixing real application +compatibility issues, smoothing common interactions, and filling session +integration gaps while keeping the core model independent of X11 and the UI. diff --git a/docs/architecture.md b/docs/architecture.md new file mode 100644 index 0000000..0f0c4a7 --- /dev/null +++ b/docs/architecture.md @@ -0,0 +1,487 @@ +# Architecture + +Lime is arranged so that task/workflow semantics stay independent of X11, and +so that X11 protocol work can grow without becoming one giant event handler. + +```text +key / menu / IPC / pointer MapRequest / DestroyNotify + | | + v v + x11/input, x11/ui x11/lifecycle + | | + +--------------> x11/commands <---------------+ + | + v + lime.core + | + v + x11/render: plan + CLX executor +``` + +## Core model + +`src/model.lisp`, `src/layout.lisp`, `src/operations.lisp`, and +`src/topology.lisp` make no X11 calls. They own Activities, Views, Heads, +Presentations, Leases, layout resolution, collision planning, topology-plan +reconciliation, and model focus state. Every core transition must preserve the +one-lease invariant and be testable without an X server. + +`src/membership.lisp` owns explicit home-Activity moves, shared eligibility, +and guarded Activity deletion (empty and unmounted only, with reference cleanup). +It prepares affected View/draft copies before mutation, then commits ownership, +layout/focus cleanup and lease release together. The adapter chooses destination +draft and layout policy; neither menus nor X events implement membership rules. +`make-client-private-in-presentation` atomically adopts the current Activity as +home and revokes sharing. It prunes other Activities' saved/live references +without replacing the current lease or changing placement, focus, or dirty state. +The lower-level, context-free `set-client-shared` retains its existing-home +revocation semantics for callers deliberately operating without a live desk. + +`src/topology.lisp` compares a desired list of logical Head ids with the +current model and builds an explicit move/suspend plan. It knows nothing about +physical outputs: a removed live Presentation either moves whole to a caller's +chosen destination or becomes an unbound, lease-free cached draft. This keeps +hotplug routing reusable from an X11 menu, IPC, or test fixture. + +`src/layout-operations.lisp` is the focused, Head-local layout command layer: +it selects manual/master-stack/monocle policy, promotes a master, and edits a +focused split or visible tiled slots. It changes only a live Presentation; +View persistence remains an explicit operation in `operations.lisp`. + +`src/floating-operations.lisp` is the equally small Head-local floating layer: +it toggles an existing placement between tile and float, validates normalized +rectangles, and keeps the tiling tree consistent. It neither knows pointer +events nor grants leases, so the same commands work from a menu, IPC, or REPL. + +The core should receive an intention such as “activate this View partially” +or “focus this visible leased client,” never an X event or a pixel rectangle. + +## X11 adapter + +`src/x11/backend.lisp` owns the CLX connection, root selection, configured +Head rectangles, backend-owned window lookup tables, and the event loop. It +does not decide layouts or issue rendering effects directly. + +`src/x11/resilience.lisp` owns the narrow X error policy, bounded diagnostic +reports, independent input-grab cleanup, and explicit recovery reconciliation. +Only request-specific vanished external-client/unviewable-focus races are +tolerated; BadAccess and Lime-owned resource failures remain errors. Failed +synchronous client queries unwind to an event/adoption boundary rather than +waiting for a reply that cannot arrive. Dispatch consumes each current event +before mutation (CLX otherwise retains it on an unwind), and returns after one +event so a busy client cannot starve developer control requests. + +The separate `lime/dev` runtime catches unexpected dispatch errors with a +pre-unwind backtrace, pauses without replacing the world, releases active grabs, +and continues servicing the owner-thread mailbox and Slynk. Explicit resume +validates model/adapter consistency and reconciles live X windows before render. +It is not a rollback, automatic retry, or persistence system. Explicit backend +restart keeps the supervisor and REPL alive through success or failure, and +constructs a replacement world from session storage when enabled. A separate lifecycle lock serializes REPL +and supervisor stop/restart operations without blocking mailbox bookkeeping. +Shutdown attempts each cleanup independently +and always attempts to close CLX. See [recovery behavior](development.md#recovering-from-an-event-loop-error). + +`lime/persistence` is separate from X11. `src/persistence/model.lisp` encodes a +versioned plain-data schema and reconstructs a fresh validated world, including +cached drafts; it derives leases from active selections/unavailable slots. +`src/persistence/store.lisp` owns bounded non-evaluating reads, a lifetime writer +lock, private atomic replacements, and file/directory synchronization. +`src/x11/persistence.lisp` supplies verified server/window tokens, physical-Head +reconciliation, restored-client adoption, debounced owner-thread snapshots, and +one off-thread disk writer. The worker never sees the live world or CLX. A +restore error blocks autosave rather than replacing a rejected file with a +blank desk. Configuration remains policy, not generated task state. See +[persistence boundaries](persistence.md). + +`src/x11/randr.lisp` discovers active physical outputs at startup and maps one +active CRTC to one logical Head; cloned outputs share a CRTC and therefore a +Head. RandR events update only an adapter-owned topology snapshot. A refresh +may safely replace rectangles when the same Head ids still exist. For added or +removed Heads, the adapter exposes a report -> build plan -> apply plan command +sequence; it rereads RandR immediately before apply and rejects a plan if the +physical Head-id set changed while a frontend was presenting choices. + +`src/x11/lifecycle.lisp` turns narrow client lifecycle events into core +commands: adopt a normal new client into the selected live Presentation, +retire a destroyed or application-withdrawn client, or ask the renderer to +restore a tiled geometry. Its pending-unmap token boundary distinguishes a +renderer-driven View hide from an application's real ICCCM withdrawal. +`src/x11/icccm.lisp` supplies the protocol details lifecycle and rendering +need: cached title/class/capability facts, `WM_STATE` normal/iconic updates, +property refreshes, graceful close requests, protocol-aware focus, and +synthetic ConfigureNotify replies. Lime removes `WM_STATE` on a real client +withdrawal. It does not change Activities or lease planning. + +`src/x11/placement-policy.lisp` consumes a managed client's transient-parent +fact only at adoption: a `WM_TRANSIENT_FOR` child follows its parent’s active +Presentation and Head, starts as a centered float, and receives focus. +Dialog-like EWMH clients float on the selected Head. Ordinary clients whose +`WM_NORMAL_HINTS` declare equal positive minimum/maximum sizes on both axes +default to centered floats too, unless a matching configuration rule requests +tiling. This is initial-placement policy only: later hint changes do not undo +manual floating/tiling choices or saved arrangements. Resizable main windows +remain tiled even when their fixed-size startup windows float. The adjacent +`src/x11/geometry.lisp` adapts resolved pixel rectangles to cached +`WM_NORMAL_HINTS` min/max/base/increment constraints inside the target Head. +Both modules are adapter policy; they never write View or Lease state. + +`src/x11/appearance.lisp` owns configurable client borders and inner/outer +tile gaps. It insets resolved slots without editing the layout tree, contains +the complete bordered frame, and applies normal hints within each tile's +remaining space. Floats bypass gaps but retain borders. The render planner +counts leased tiles with resolved geometry separately on each Head; a sole +visible tile bypasses gaps and borders in every layout. This also covers +monocle without a layout-name special case. Normal hints and the bar's work +area still apply. Fullscreen +bypasses all decoration, normal hints, and the bar reservation. +The adapter caches allocated border colors and original application border +widths, restoring widths on withdrawal or shutdown. Configuration reloads +repaint the same draft rather than turning theme choices into saved View data. + +`src/x11/render.lisp` has two separate jobs: + +1. `build-render-plan` derives inspectable `x11-effect` data from active + Presentations—currently configure, map, unmap, float raise, and one + input-focus effect. Configure effects include content geometry, border + width, and the color chosen for global client focus. +2. `execute-render-plan` performs that plan through CLX and flushes it as one + batch. It rejects a plan if the core world revision changed after planning. + +The temporary `apply-active-presentation` name remains as a small convenience +wrapper around those two operations. It then redraws the adapter-owned Head +bars; that UI state is deliberately outside the model render plan. Normal +layouts and floats resolve against `x11-head-work-area` (below a configured +top-bar reservation), while EWMH fullscreen still resolves against the whole +physical Head. New policy-aware callers can inspect a plan before executing +it. + +`src/x11/commands.lisp` is the frontend-neutral imperative API. A keybinding, +menu, REPL, or future IPC service calls it to choose an already-tested core +transition and request one reconciliation. It also owns Head-relative +selection and focused-client transfer: the target draft retains any existing +placement, otherwise the source tile/float placement is copied, and the core +performs the exclusive lease move. Private clients require the same Activity; +shared clients may transfer across Activities without changing their home. +The interactive `backend-send-focused-client-*` entry points live in `ui.lisp`: +eligible transfers run immediately, while a private cross-Activity send offers +a named confirmation with Cancel selected. It captures the window, both live +arrangements, focused Head, and world revision, rejecting stale choices. +Confirmation calls the separate `backend-rehome-client-to-head` command and +core `move-client-to-presentation` transaction: membership, old-checkpoint +pruning, new placement, and the single lease commit together after validation. +Neither monitor switches Activities. After a successful send, keyboard focus +and command/new-window routing follow the moved window to the destination Head; +the source remembers a surviving client for when the user returns. Cancelled or +rejected sends do not change focus. +`backend-move-client-to-activity` explicitly rehomes a visible client and queues +it in the destination Activity's draft for the same Head without switching. +`backend-set-client-shared` enables sharing without moving the window; NIL calls +`backend-make-client-private`, which keeps it private to the current Activity. +That explicit command also accepts a Head and expected revision. The menu names +the Activity, defaults to Cancel, and rejects changed focus/desk/revision before +calling it. The hidden-window picker includes shared guests and asks before +transferring an existing lease. +`src/x11/input.lisp` only turns a +passive X key grab into such a command; it contains no View names or lease +rules. Passive grabs synchronously queue subsequent keyboard input until the +handler either opens an asynchronous palette grab or finishes; an unwind-protect +always thaws input, including failed or missing handlers. This closes the gap +where releasing the shortcut before a slow menu opened sent typed letters to +the previously focused application. The pointer remains asynchronous. +`src/x11/default-bindings.lisp` supplies the default, replaceable +dwm-shaped starter map plus named Activity/View/Head configuration helpers; it +owns neither X events nor model policy. `src/x11/pointer.lisp` does the +equivalent minimal routing for unmodified Button1 plus Super+Button1/2/3 +float move/toggle/resize gestures. It uses passive grabs so +a click in an application's child window reaches the managed client boundary; +an ordinary managed-client click resolves to its leased Head, focuses that +client, then replays the click to the application. A Super gesture focuses a +floating client and turns its root-pixel motion into a normalized geometry +command. Consecutive queued motions from the same gesture are coalesced in +bounded batches; key/button/lifecycle events are never skipped. Release applies +its final coordinates, and a gesture is cancelled if its original Presentation +or floating lease is no longer current. Geometry-only commands configure just +that client through the usual layout/border/normal-hint calculations, without +reapplying focus, stacking, EWMH inventories, or other clients' rectangles. +Only the clean-to-dirty transition redraws bars. Blank root space selects that +Head and deliberately focuses root. +The adapter owns reusable `left_ptr` and `hand2` cursors. Bars and dropdowns +inherit the root arrow except over their measured clickable regions, where +only that UI window selects the hand. Application-specific cursors are +untouched. Enter/motion/leave events update the cursor; redraws also recheck +the pointer so changed widgets, filtered lists, and resized menus cannot +leave a stale hand or highlight under a stationary mouse. This is event-driven, +not a pointer polling timer. Root selection is confirmed before installing +the arrow, and shutdown releases both cursor resources. + +`src/x11/cursor.lisp` owns cursor configuration, assets, and resource lifetime; +`pointer.lisp` only routes gestures and selects arrow/hand roles. Optional +libXcursor loads theme images into memory, including inherited/default themes. +CLX uploads their ARGB pixels through X Render on the existing WM connection, +independent of root visual depth. There is no additional Xlib connection or +GTK dependency. Temporary images, pixmaps, GCs, pictures, and animation frames +are released after upload; the installed cursor set lives until replacement +or shutdown. Theme/size reload is transactional with the rest of configuration: +old cursors remain live until commit, and rollback rebinds the original XIDs, +including on hovered UI. Unsupported/missing theme facilities use core cursors +with diagnostics available through `backend-cursor-report`. + +`src/x11/session-settings.lisp` is the application-facing settings boundary, +separate from cursor rendering. Explicit cursor config publishes only +`Gtk/CursorThemeName` / `Gtk/CursorThemeSize` using the +[XSETTINGS protocol](https://specifications.freedesktop.org/xsettings/latest/). +It claims `_XSETTINGS_Sn` only when vacant, announces a complete initial property +with a real server timestamp, preserves unrelated queued events, and destroys +its owner window on SelectionClear without stealing ownership back. Existing +managers remain authoritative for their toolkit clients. + +The same layer owns reversible cursor-only RESOURCE_MANAGER edits and a child +launch-environment overlay. It preserves unrelated resource records and later +external edits; resolving NIL defaults excludes Lime's own publication. No +desktop config files, process-global environment, or activation environment +are mutated. Configuration failure restores prior publication; shutdown +releases it before closing X. Runtime ownership lives in a backend-keyed table, +not the pure model or session persistence. Clients may cache settings; protocol +publication cannot force an application to replace its own cursor resources. + +`src/x11/config.lisp` is a user-facing adapter-policy layer, exposed as +`lime.config`. Its `DEFCONFIGURATION` macro produces ordinary data: +first-class commands, bindings to those commands, ordered initial window +rules, window appearance, optional bar settings, and startup hooks. The configuration is held by +the backend, not the core world. A named command appears in direct palette +search and, when it has a key letter, under the palette’s User branch as well +as being eligible for a physical binding. Reload validates all data before it +touches X11 and rolls back binding/bar/appearance settings after an installation error; it +never recreates Activities, Views, Presentations, leases, or Viewsets. Current +rules style only ordinary new clients (float/center) and intentionally cannot +make a class match mount a View or move a client between task contexts. + +`src/x11/navigation.lisp` owns contiguous Activity positions, stable Activity-local View slots, +and last-used Presentation ids per `(Head, Activity)`. A separately owned, +backend-keyed runtime avoids changing core identities or the live backend's +structure; shutdown releases it (SBCL also uses weak keys). Rendering records +active arrangements once per model revision. Slot reassignment changes only +navigation metadata, whose own generation participates in session autosave. + +`src/x11/activity-navigation.lisp` owns persistent portable/extended navigation +intent and the portable arrangement id. New named Activities are portable; +the bootstrap Scratch desk starts with its existing per-Head blank portions. +`src/presentation-navigation.lisp` supplies the pure atomic bring/swap operation: +it preserves active lease identity, transposes displaced cached portions, and +preflights inactive resumes without replaying missing checkpoint slots. +Portable checkpoint recall previews the compound move/recall on a detached +world before any live mutation, so a lease conflict or cancellation never +swaps monitors as a side effect. Explicit multi-Head Viewsets and direct +multi-portion model edits remain capable of extending an Activity. +The footprint sidecar has its own autosave generation; it is not a slot added +to live backend or model structures. `activity-navigation-ui.lisp` exposes +extension and return-to-portable commands through the normal dropdown, with +cancel-first choices and stale-context guards. +Activity deletion closes gaps while preserving surviving bar order; new +Activities append. Persisted sparse Activity slots are validated before being +compacted. Explicit Activity slot assignment swaps within the existing count, +whereas View assignments retain their stable, gap-filling policy. +The versioned X11 session envelope stores these indexes separately from the +pure world. The core's unique `(Activity, Head)` arrangement is authoritative; +last-used ids remain migration metadata, not a separate navigation target. +Activity navigation resumes current locations without a collision menu. +Explicit checkpoint recall still uses lease preflight/choice commands. `:navigation-keys` expands +to ordinary configuration commands/bindings rather than hardcoded key policy. + +`src/viewset.lisp` adds the corresponding grouped core planner for named +whole-desk shortcuts. It records only `Head -> View` entries, preflights every +target Head as one outgoing group, and commits one atomic multi-Head lease +transition. `src/x11/commands.lisp` exposes save/preflight/strict/partial/take +commands; no X11 frontend is allowed to recreate that grouped collision logic. + +## UI boundary + +`src/ui/session.lisp` is a renderer-neutral direct-search, one-string-prompt, +and key-tree session. It owns a candidate list, filtering, selection, +minibuffer text, a key-path stack/page, and declarative results (`:close`, +`:keep-open`, `:replace`, or `:prompt`). Candidate actions and key nodes are +supplied by a frontend, which makes a collision prompt an ordinary replacement +candidate set, a name prompt an ordinary session transition, and a which-key +menu a data tree rather than special modes embedded in a View-switch command. +`MAKE-UI-SESSION` explicitly selects `:search` (the default for standalone +pickers) or `:key-path` (the Super-y menu). A separate root candidate catalog +survives scoped/collision pickers: menu → search always restores the complete +catalog rather than accidentally searching the last replacement list. + +`src/x11/bar.lisp` supplies the first reusable persistent UI surface: one +override-redirect bar per Head. It renders Activity names (not checkpoint or dirty +state), the Head-local layout token, and a focused-client title section whose +colors identify Head focus. Its optional right-side providers return `HEAD-BAR-SEGMENT` values +and may give each segment a click action; music, volume, and clock integration +therefore remain configuration rather than model state. The `Lime` segment +opens the palette and the layout segment cycles the local layout. The Activity +strip is slot-ordered on every Head; that Head's active entry uses the accent +foreground. Saved Views live in the recall/save/update menu; updates choose a +named target and confirm replacement rather than infer it from the last recall. +Each independently shaped run +owns its click region, reusing ordinary Activity resume and lease prompts. +Budgeted overflow retains the active entry and nearby slots when possible, +with a dedicated `…` target opening an Activity-only picker. Neither clipping +nor clicking invents new layouts, changes membership, or takes leases silently. + +`src/x11/status.lisp` owns opt-in managed provider lifecycle and cached data, +separate from `bar.lisp` painting and `status-desktop.lisp` source protocols. +Each managed provider has one cancellable worker per backend, not per Head. +Workers publish changed data snapshots under a lock and send one coalesced +`_LIME_STATUS_CHANGED` event through a separate, serialized CLX notification +connection to an unmapped adapter-owned window. They never use the WM's X +connection or access model state. The ordinary X event loop consumes the wake +and redraws bars on their owning thread—even when there has been no keyboard, +mouse, or client event. No status refresh timer is attached to bar rendering. + +Music publishes playback/title/source facts, volume publishes percentage/mute/ +sink facts, and the clock publishes local date fields. A configuration-supplied +`:formatter` consumes a defensive copy on the X thread, outside worker locks, +and returns text, NIL, or a `HEAD-BAR-SEGMENT` with optional foreground, width, +and click overrides. `status-format.lisp` contains optional, parameterized +presentation helpers, not subscription logic. Config therefore chooses icons, +spacing, date style, visibility, and colors without editing protocol code. +Legacy generic providers may still publish strings through an identity +formatter. Formatting failures hide one widget without stopping its source or +other widgets. The bar's overall left/title/right geometry remains renderer +policy; this seam does not claim an arbitrary bar-layout language. + +MPD snapshots and `idle` use the same native connection, retaining events +between query and subscription. MPRIS uses the documented +[playerctl follow interface](https://github.com/altdesktop/playerctl#following-changes); +audio uses a persistent `pactl subscribe` process and bounded one-shot reads. +The clock alone schedules a wall-time deadline, recomputed for each minute. +See the [MPD idle protocol](https://mpd.readthedocs.io/en/stable/protocol.html#idle) +for the accumulated-event guarantee. Reconnection timers use 1–30 second +backoff only after service failure; they are not a healthy-state polling loop. + +Configuration validation accepts managed sources alongside legacy pure +provider functions. Reconciliation keeps identical provider objects, cancels +removed workers, and starts replacements; rollback reinstalls the previous +set. Shutdown wakes sleeping workers, shuts down owned MPD sockets, and kills +and reaps only owned child helpers. Provider failures are retained in +`backend-status-provider-report`, not allowed to kill the X loop or display +stale cached data. Public worker functions must cooperate with cancellation. + +Bar text is shaped and measured by the shared Pango/Cairo font layer, with a +bounded per-font metrics cache. A server-free text-layout helper computes pixel-budgeted truncation and +positions, shared by drawing and click regions. Identity and layout fields +use measured ` | ` separators; the title is left-aligned inside an expanding +section with two muted one-pixel edges, and status text is right-aligned. +Validated `:padding-x` controls matching outer text margins and title insets; +the separator's own space supplies the gap after `Lime`, without duplicate +logo padding. The same layout data positions paint and click targets. A font-derived optical +baseline centers a stable letter-body reference instead of unused line leading. +Every bar field uses that baseline, independent of its current text or fallback +font's ascent, avoiding title-content-dependent vertical jumps. +`HEAD-BAR-STYLE` is validated configuration, separate from window appearance +and layout. Each bar caches its own colormap allocations and releases unused +colors on redraw/configuration rollback and shutdown. Oversized status text is truncated while +preserving room for the layout control and a small Activity navigation area. +Ordinary separators and status truncation dots do +not acquire status click actions. Each provider is shaped independently so +bidirectional text cannot reorder adjacent widgets; click regions use the +shaped source text's visual ranges, not an assumed character advance. + +`src/x11/attention.lisp` owns a backend-only, two-source request cache for +ICCCM urgency and EWMH demands-attention. Property/client-message events update +it without touching the world revision. The renderer's global input target and +normal FocusIn events acknowledge only a selected visible client with verified +X focus; another Head's local focus, root focus, or a palette grab is not enough. +The cache is not serialized: adoption rereads surviving clients' protocol state. +The bar renders a configurable global count using its existing status-segment +and click machinery; the picker consumes cached data and calls +`backend-attend-client`. Visiting an Activity resumes its current arrangement +without restoring stale claims for unrelated windows. +See [attention](attention.md) for the protocol and interaction boundaries. + +The cached client title prefers EWMH `_NET_WM_NAME` decoded with Babel over +ICCCM `WM_NAME`. Title/class property events repaint bars without touching +geometry, leases, or draft dirty state. `src/x11/text-native.lisp` contains +the narrow CFFI boundary to Pango, Cairo, and GLib. `src/x11/text.lisp` owns +font descriptions, shaping/measurement, grapheme-safe fitting, clipped +painting, and pixel upload for both bars and the palette. Pango handles +Fontconfig fallback and shaping, including color emoji with installed fonts. +Cairo paints a complete opaque RGB frame in memory; CLX uploads it on the +existing WM connection. The font renderer needs no extra Xlib connection or +toolkit event loop (the optional status notifier described above is separate). +The adapter requires a TrueColor root visual and converts RGB pixels to its +actual masks (including 16-bit displays). The pure model and `lime/ui` +remain independent of these native libraries. + +Each UI surface owns a font/layout and a resize-reused canvas, operated only +by the backend thread. Font replacement allocates before freeing the old +resource; close, Head removal, resize, rollback, and shutdown release native +resources explicitly. `UI-FONT-STYLE` is validated configuration, shared by +both surfaces. A font reload repaints/resizes an open palette without replacing +its search session. This font-rendering boundary does not add an IME. + +`src/x11/ui.lisp` builds the command catalog/tree and owns keyboard-grab/input +routing. `src/x11/ui-render.lisp` owns the temporary X11 surface, fonts, +canvases, measured geometry, and painting. Its server-free grid projection +chooses up to four columns, fits labels in pixel budgets, and pages large +trees within the Head-local dropdown. The renderer clamps the session's +requested page when font/Head dimensions change. Height follows the current +menu or picker instead of reserving a fixed ten-row block. Keys, submenu +labels, breadcrumb, and footer have distinct visual roles; detailed candidate +descriptions appear only for the selected search result. The dropdown reuses +the configured bar colors through the adapter's style seam, rather than +hard-coding black/white. It draws directly below the persistent bar. Its Activity and +View choices call the command layer. A collision first performs the normal +read-only preflight, then offers the already-public strict, partial, and take +commands explicitly. The overlay is frontend state only: no X11 window, +keyboard grab, search query, or visual styling leaks into `lime.core`. + +The same replacement-candidate mechanism drives RandR reconciliation. A +pending added/removed-Head snapshot contributes one direct-search candidate +and a `Head -> topology` key-path entry. The frontend collects one move or +suspend choice for every removed live Presentation, shows a final Apply choice, +then calls the separate RandR build/apply commands. It never reacts directly +to an output event or invents a second modal UI protocol. + +Super-y and the bar logo open the key root; Super-p remains the separate fuzzy +program picker. Executable discovery is cached in the launcher adapter, keyed +by PATH, current directory, and PATH-directory modification dates. A five-minute +maximum cache age catches permission-only/coarse-timestamp changes on the next +open; no timer polls while idle. Name deduplication uses a hash table rather +than quadratic list comparisons. Each palette gets fresh candidates/actions; +the cache holds only executable names, not a stale backend or UI session. +Space (unless explicitly bound in a custom tree) or Tab opens +global search; Tab returns to the root map. Prompts retain literal spaces and +cannot switch modes with Tab. Backspace goes up a prefix and Escape dismisses +the entire overlay without dispatching another command. Key cells and search +results are also clickable, with hover feedback and small Back/Search/Menu/ +Confirm/Close controls as appropriate. Wheel input navigates menu pages or +search selection; paged grids also expose previous/next buttons. Geometry is +shared by painting and clipped hit regions, rebuilt each frame. Mouse events +on the overlay are consumed before client focus/drag routing, including clicks +in blank space. No global pointer grab is needed. Both input paths share the +same session transitions and error boundary; candidate clicks carry the actual +candidate object and reject stale choices instead of reusing a list index. + +Richer text input, dynamic workflow-specific trees, themes, and decorations +can reuse the same session protocol or add another +renderer without changing Activity/View/Lease rules. + +## Direction of dependencies + +Dependencies should point inward toward the core, never the reverse: + +```text +input / pointer / menu / IPC -> commands -> lime.core +user configuration -> commands + input + bar + lifecycle policy +ui session -> commands -> lime.core +x11 bar / UI renderer -> ui session + CLX + adapter snapshots +lifecycle -> lime.core +icccm -> CLX +ewmh -> commands + CLX + active Lease queries +randr -> CLX + backend Head rectangles + core topology plans +render -> lime.core + ICCCM/EWMH + CLX +backend -> CLX + module interfaces +``` + +That leaves room for an IPC frontend, richer Viewset editing, an interactive RandR +topology picker, remaining ICCCM/EWMH work, richer pointer policy, and +alternate layout engines without forcing the Activity/View/Lease model to know +about physical output APIs. diff --git a/docs/attention.md b/docs/attention.md new file mode 100644 index 0000000..93a3bab --- /dev/null +++ b/docs/attention.md @@ -0,0 +1,78 @@ +# Application attention + +Lime watches ICCCM `WM_HINTS` UrgencyHint and EWMH +`_NET_WM_STATE_DEMANDS_ATTENTION`. A request adds a quiet, clickable `! N` +badge to every visible Head bar. There are no flashes, popups, timers, or +automatic Activity switches. A window requesting both hints counts once. + +Click the badge or use **Super-y → w → a** for a searchable list across all +Activities. The direct command search also offers “Windows needing attention”. +Entries show the Activity and the current application title. The ordinary +hidden-window picker marks requesting windows with `!`, and Activity search +shows request counts in its details. + +## Visiting a request + +- A leased window is focused on the Head that already owns it. It is not + pulled onto the Head where you opened the picker. This also works for a + non-visible member of a monocle stack. +- A hidden window is shown in its own Activity on the selected Head. If + necessary, Lime resumes that Activity's **draft**, not an arbitrary saved View. +- Resuming a draft with contested windows still offers explicit partial/take + choices. Opening or cancelling that choice does not change either Head. + The target and its lease are checked again when you select an option. +- Visiting a window behind a different fullscreen window exits that fullscreen + state so the requested window can actually be seen. Visiting the fullscreen + window itself preserves fullscreen. +- Revealing a hidden window edits the live draft normally; it never rewrites + a checkpoint. Merely receiving or displaying attention changes no model state. + +Lime acknowledges attention when the selected, visible input target actually +has X focus, including focus inside a child widget. Another Head's saved focus, +root/background focus, and an open command-palette grab do not count. Clients +using `WM_TAKE_FOCUS` keep their request until they actually answer by taking +focus. Closing the menu after a visit then acknowledges the chosen application. + +Acknowledgement clears only the urgency flag and the demands-attention atom; +other `WM_HINTS` fields, fullscreen, and unrelated EWMH state remain intact. +Applications can cancel either source independently. Destruction and genuine +withdrawal remove the client from the list; stale picker entries cannot revive it. + +## Boundaries + +This is **application attention**, not a desktop notification daemon or an +unread-message counter. Applications must publish the relevant X11 hints. +A game's fullscreen Head still hides its bar; another visible Head can show +the badge, and the menu remains accessible. Disabling the badge or the entire +bar does not disable the picker. + +Attention is adapter-local, never part of session snapshots. Surviving X +windows have their current hints reread when adopted after a WM restart. +Dead windows and old alerts are not resurrected from disk. Hidden +`_NET_ACTIVE_WINDOW` requests which Lime declines become attention requests; +the existing activation policy for already leased clients is otherwise unchanged. + +Configuration controls the badge's color, marker, and visibility; see +[bar appearance](configuration.md#bar-appearance). No personal configuration +changes are required for the default badge/menu. This addition changes backend +structure and ASDF components: use a fresh Lime process to load it, rather than +a function-only hot reload. Your running session is not modified by installing +the code. + +## Implementation and tests + +`src/x11/attention.lisp` owns the live source cache and acknowledgement. +ICCCM/EWMH adoption and property/client-message handlers feed it; focus effects +and normal FocusIn events acknowledge it. Focus queries run only for pending +requests, not as an idle poll. Bar/UI code consumes cached queries; the command +layer owns visiting and the ordinary Activity/lease transitions. + +The owned-Xvfb smoke test is `test/x11-attention-smoke.lisp`. It covers real +ICCCM/EWMH changes and cancellation, both message atom slots, initial hints, +NoInput and asynchronous child focus, hidden and inactive Activities, bar clicks, +which-key visits, independent Heads, fullscreen preservation, stale selections, +and withdrawal/destruction. Server-free tests also cover partial/take collisions, +stale choices, checkpoint isolation, and configurable presentation. + +Protocol references: [ICCCM WM_HINTS](https://www.x.org/releases/current/doc/xorg-docs/icccm/icccm.html) +and [EWMH window state](https://specifications.freedesktop.org/wm/1.5/ar01s05.html). diff --git a/docs/configuration.md b/docs/configuration.md new file mode 100644 index 0000000..17fa849 --- /dev/null +++ b/docs/configuration.md @@ -0,0 +1,674 @@ +# Configuration + +Lime’s configuration is a user-owned Common Lisp file—not a source-tree fork +and not a collection of patches. Load `lime/x11`, then start through +`lime.config:start-lime` with the file path you want to own, for example +`~/.config/lime/config.lisp`. + +```lisp +;;;; ~/.config/lime/config.lisp +(in-package #:cl-user) + +(lime.config:defconfiguration my-lime + (:options :default-keybindings t + :default-modifiers '(:mod-4) + :default-layout :master-stack + ;; New tiles append at the bottom of master/stack, but receive + ;; focus; closing one returns focus toward master. + :new-client-focus t + :new-tiled-client-position :back + :close-focus-direction :previous) + + (:command terminal + :label "Terminal" + :description "launch Alacritty" + :category "Launch" + :key #\t + :action (lambda (backend) + (declare (ignore backend)) + (uiop:launch-program '("alacritty") :output :interactive))) + (:command reload-config + :label "Reload configuration" + :description "reload this file without restarting Lime" + :key #\r + :action #'lime.config:reload-configuration) + (:command palette + :label "Command palette" + :description "open Lime's command picker" + :action #'lime.x11:backend-open-command-palette) + + ;; This replaces the starter map's Super-t binding with TERMINAL. + (:bind #\t terminal :modifiers '(:mod-4)) + (:bind #\y palette :modifiers '(:mod-4)) + (:bind #\r reload-config :modifiers '(:mod-4 :shift)) + + ;; Rules are ordered. The first match styles an ordinary newly mapped + ;; client; strings are case-insensitive exact ICCCM WM_CLASS matches. + (:rule :class "mpv" :float t :center t) + (:rule :class "Pavucontrol" :float t :center t) + + (:font :family "monospace" :size 14 :weight :normal) + (:bar :height 22 + :status-providers (list (lime.x11:make-clock-status-provider))) + (:appearance :border-width 3 + :focused-border "#ffac54" :unfocused-border "#121f25" + :inner-gap 5 :outer-gap 5)) +``` + +```lisp +(asdf:load-system "lime/x11") +(lime.config:start-lime + :display-name ":99" + :config-file #P"/home/adan/.config/lime/config.lisp") +``` + +`Super-y`, the clickable `Lime` bar item, and a command’s optional +`:key` all meet in the same command registry. `Super-p` is deliberately kept +for the immediate dmenu_run-like PATH-program picker. `:key` places a command under the +palette’s `User` which-key branch; it does not make an X key grab by itself. +Use `:bind` for that. Commands are ordinary functions, so anything beyond this +small DSL is just Common Lisp calling Lime's public command functions. + +The program picker caches PATH executable names. It refreshes when PATH or a +directory modification date changes, or after five minutes on the next open +(covering executable-permission edits). For immediate rediscovery from the REPL, +use `(lime.x11::%path-program-names :refresh-p t)`. Opening shortcuts queue rapid +follow-up keystrokes safely until the menu takes over, including cold launches. + +## Numbered navigation + +The starter map binds `Super-1` through `Super-9`, then `Super-0`, to Activity +positions 1–10 in the Activity bar order. Add Shift to select View slots 1–10 +**inside the current Activity**. +For a complete personal keymap with starter bindings disabled, opt in with: + +```lisp +(:navigation-keys) +;; Or use another modifier family: +;; (:navigation-keys :modifiers '(:mod-1)) +``` + +This clause expands into ordinary named commands and bindings. It inherits +`:default-modifiers` unless explicitly overridden. For individual custom keys, +commands can call `backend-select-activity-slot` or `backend-select-view-slot`. +The clause uses command ids `:navigate-activity-1` … `:navigate-activity-10` +and `:navigate-view-1` … `:navigate-view-10`. + +Numbers are durable navigation metadata, not identities or a ten-Activity +limit. The bar shows Activity names only, such as `Work`; the picker retains each +Activity/View's number for reference. The bar lists Activities in slot order. +Saved Views are arrangements to recall, not subworkspaces: no View name, +Draft label, or dirty marker appears in the bar. Active text +uses the configured `:accent-color` (falling back to `:focused-foreground`); +inactive text uses `:foreground`, without changing background colors. +Click a name to use the same portable/extended navigation as the number keys. +Clicking the already active name restores client +focus without resetting its arrangement. Long lists retain the active tab +where space permits and use a clickable `…` Activity picker for overflow; +title and status areas remain bounded. Custom commands can open the same +picker with `backend-open-activity-picker`. + +Activity numbers are contiguous positions: deleting an Activity shifts later +ones left, and new Activities append to the end. Existing order is otherwise +preserved, including across restarts; older sparse assignments are compacted +in their existing bar order. No Activity identity, window, View, or lease changes. +On narrow bars, the `…` picker shows the full order, including clipped tabs. + +Drafts have no View number. View slots remain stable and local: new Views take +the lowest free slot and deleting one does not renumber the others. Previously +unnumbered sessions start with Scratch on 1, then Activities alphabetically; +existing Views use library order. Beyond position/slot 10, use name search or +reassign a shortcut. Empty shortcuts do nothing. Session persistence saves +navigation metadata across restarts; without it, the order lasts for this runtime. + +New Activities are portable: selection brings their current arrangement here, +including unsaved edits. If already displayed elsewhere, the two monitors swap +arrangements; an inactive Activity changes only the selected monitor. Numbered selection of the current Activity +or View is a no-op, not a reset. Selecting another View recalls its checkpoint. +The menu's explicit `Recall view...` restores a checkpoint even when it was the +last one recalled. For portable Activities, recalling a checkpoint on another +monitor first brings that Activity's arrangement there; lease conflicts are +checked before either step, so cancelling does not swap monitors. A View still +cannot be mounted twice. Extended Activities retain independent Head-local +recall and explicit partial/take lease choices. +Both `backend-activate-activity` and `backend-switch-to-activity` use the same +current working arrangement. Activity navigation never reloads a checkpoint +or retries an old window claim. Moving a window updates its previous live +location even while that Activity is undisplayed. Hidden windows remain hidden +when an arrangement travels; ordinary navigation never gathers the whole pool. + +`Super-y → a → e` chooses a monitor to **extend** the current Activity onto. +Its existing portion stays put; a new portion is empty, or an existing portion +resumes. That Activity then navigates independently per Head, even when one +portion becomes empty. `Super-y → a → p` makes the current portion portable +again once other portions are empty and inactive; it preserves saved Views +and hidden windows. Both actions are also searchable commands. +Noninteractive callers use `backend-extend-activity-to-head` and +`backend-make-activity-portable`; `backend-activity-navigation-mode` reports +`:portable` or `:extended`. The startup Scratch desk retains its initial blank +per-Head portions; newly created named Activities default to portable. + +Sending a window to a portable Activity targets its real arrangement, even on +another monitor. It appears there if that arrangement is active, otherwise it +is queued there; focus stays with the sending monitor. Extended destinations +still use the sending monitor's portion. + +`Super-y → v` contains saved-arrangement actions: `s` saves a new named +checkpoint, `o` recalls one, and `u` chooses a saved view in the current Activity +to replace. Updating requires a named confirmation (Cancel is selected first) +and rejects stale choices if the desk changes. The starter `Super-Shift-s` +binding opens this same picker via `backend-open-view-update-picker`. Advanced +Lisp callers can still explicitly use `backend-update-view` or +`backend-update-current-view`; the UI no longer silently targets the last recall. + +For interactive monitor sends, bind a command calling +`(lime.x11:backend-send-focused-client-relatively backend :next)` (the starter +`Super-Shift-e` binding). It transfers same-Activity/shared windows immediately +and opens a Cancel-first confirmation for a private cross-Activity move. +Successful sends follow the window with keyboard focus and route subsequent +commands/new windows to its destination Head. Cancelling leaves focus unchanged. +The same entry point works inside configured menu commands. Strict non-prompting +`backend-transfer-focused-client-*` APIs still reject private cross-Activity +transfers; they never silently change home membership. + +Shortcuts can be reassigned through the REPL; occupied assignments swap. +Activity positions must be within 1 through the Activity count, so reordering +cannot create a gap. View slots may still be any positive integer: + +```lisp +(lime.dev:with-development-backend (backend) + (lime.x11:backend-set-activity-slot backend "work" 2) + (lime.x11:backend-set-view-slot backend "work/docs" 3) + (lime.x11:backend-navigation-slots backend)) +``` + +## Browser launch profiles + +The built-in Waterfox command and the PATH picker use the browser's normal +profile selection, like running `waterfox` in a terminal. Testing alongside +another graphical session can explicitly opt into an isolated profile: + +```lisp +(lime.x11:backend-launch-browser backend :test-profile-p t) +``` + +That test profile lives in Lime's XDG state directory (`lime/waterfox-profile/`) +and intentionally has separate tabs, settings, and extensions. It is never +selected implicitly for normal desktop use. + +Super-y opens the compact key map first: `w → +Windows` enters the Window +group, for example. Space or Tab opens command search, Backspace goes up a +menu level, and Escape closes. Tab in search returns to the root map. Large +User groups can be paged with PgUp/PgDn. The dropdown uses the bar's configured +background, foreground, focus, separator, and edge colors, plus the shared +font below; it no longer has a separate hard-coded black/white appearance. + +## Configuration versus session state + +Your configuration defines policy and commands. Activities, saved Views, +Viewsets, and drafts are automatically stored separately when using `lime/dev`. +Choose `:session-file :default`, a pathname, or `nil` on the session launcher; +the lower-level `lime.config:start-lime` defaults to no session persistence. +Reloading this configuration does not reload or replace the desk. See the +[persistence guide](persistence.md), including the distinction between restarting +Lime and relaunching applications after logout. + +## Status widgets + +Opt into managed providers in your own configuration; no music/audio services +are started by Lime's starter configuration: + +```lisp +(:bar :height 22 + :status-providers + (list (lime.x11:make-music-status-provider + :source :mpd :sources '(:mpd "spotify") + :mpd-host "127.0.0.1" :mpd-port 6600 :maximum-width 320 + :formatter (lambda (data) + (lime.x11:format-music-status data + :playing-icon "" :paused-icon "" :icon-gap " "))) + (lime.x11:make-volume-status-provider + :foreground nil ; inherit the bar's color, or set "#RRGGBB" + :formatter (lambda (data) + (lime.x11:format-volume-status data + :icon "" :muted-icon "" :icon-gap " "))) + (lime.x11:make-clock-status-provider + :formatter (lambda (data) + (lime.x11:format-clock-status data + :icon "" :icon-gap " " :twenty-four-hour-p nil))))) +``` + +Subscriptions publish **data**, not display strings. The configuration owns +the ordered provider list, formatters, icons, gaps, optional per-widget colors, +width limits, and click actions. Rendering still owns the overall left/title/ +right bar geometry; this is not yet an arbitrary bar-layout DSL. + +Each `:formatter` is a fast function of one cached data plist: + +| Provider | Snapshot fields | +| --- | --- | +| Music | `:state` (`:playing`, `:paused`, `:stopped`, `:unknown`), `:title` (string/NIL), `:source` (`:mpd` or MPRIS player name) | +| Volume | `:volume` (first-channel integer percentage), `:muted-p`, `:sink` (output name) | +| Clock | `:universal-time`, `:minute`, `:hour` (0–23), `:day`, `:month`, `:year`, `:weekday` (Monday=0), `:daylight-p`, `:timezone` (CL hours west of GMT) | + +The clock publishes at minute resolution, even if a custom formatter decodes +seconds from the initial timestamp. NIL source data means unavailable: the +widget is hidden and its formatter is not called until data arrives. + +A formatter may return a string, NIL to hide available data, or a +`head-bar-segment`. For example, this configuration can color muted volume +differently without making the source know anything about themes: + +```lisp +:formatter +(lambda (data) + (lime.x11:make-head-bar-segment + :text (lime.x11:format-volume-status data :icon-gap " ") + :foreground (if (getf data :muted-p) "#9f9584" "#d8c9ad"))) +``` + +Segment foreground/width/click overrides take precedence over the provider's +defaults; NIL fields inherit those defaults. Provider `:foreground nil` +inherits the bar foreground. Colors must be `#RRGGBB`. Invalid formatter +output or a formatter error hides only that provider and records a diagnostic; +other widgets and subscriptions keep running. Formatters run on the X thread, +outside worker locks, on a defensive copy. They must not block or do I/O. + +The `format-*-status` functions are optional presentation helpers in +`src/x11/status-format.lisp`, not part of the subscription protocols. Supply +your own formatter for a different date format, stopped-track display, labels, +or icons (NIL/empty icons omit both icon and gap). Helpers default to one space +for music and two for volume/date. `:twenty-four-hour-p` now belongs to +`format-clock-status`, not `make-clock-status-provider`. + +Pass `:icon-foreground "#76929f"` to any of these helpers for a colored icon +with an independently colored label. With this option the helper returns a +`head-bar-segment` instead of a string; the label still inherits the provider +or bar foreground. Without it, the existing string/NIL behavior is unchanged. +For example: + +```lisp +:formatter (lambda (data) + (lime.x11:format-volume-status data + :icon-foreground "#76929f" :icon-gap " ")) +``` + +Custom segments can use `:prefix-length` (Lisp character count, not UTF-8 +bytes) and `:prefix-foreground` for the same effect. The icon and label remain +one shaped item and one click target; fitting never colors truncation dots as +part of the icon. Text is still plain text, not markup. + +Music uses a native MPD connection with `idle player playlist`, or a long-lived +`playerctl --follow` process for an MPRIS player name such as `"spotify"` or +`"brave"`. Default formatting hides stopped players; a custom formatter can +show their retained data. Disconnected players disappear. Paused tracks retain +their pause indicator. The song's pixel budget truncates at grapheme boundaries, +leaving room for the following widgets. Volume uses `pactl subscribe` and +queries the default output only initially and on relevant events. It follows +mute, volume, output changes, and hotplug; the first channel percentage matches +the old dwm script. Queued bursts are coalesced without a debounce delay. +The clock shows local date/time and recomputes the next wall-clock minute +boundary after every wake, not a repeating sleep measured from startup. +It is a date/time widget, not a calendar/appointment application. + +The external event bridges need `pactl` (PulseAudio or PipeWire-Pulse) and +`playerctl` (only when using MPRIS); MPD controls use `mpc`. The built-in desktop +sources currently target SBCL/Linux. MPD host/port/password are explicit +constructor options, not inferred by reading a shell script. MPRIS and audio +inherit the session's D-Bus/audio environment; a nested Xephyr session will +normally share the host user's player and volume. No controls are invoked +merely by displaying the widgets. + +Click music to play/pause; click volume to toggle mute. Each constructor accepts +an optional `:click-action` function of `(backend head-id)` to customize this. +The clock has no default click action. Bind these commands through your usual +configuration command registry: + +```lisp +(lime.x11:backend-cycle-music-source backend) ; :mpd -> "spotify" -> :mpd +(lime.x11:backend-music-command backend :toggle) ; also :next / :previous +``` + +The widget and controls share the same selected source. An optional `:id` +supports multiple music providers; commands accept the corresponding `:id`. +Reloading a newly evaluated music constructor resets its source to the +configuration's `:source`. Your dwm scripts remain independent. + +Managed providers share one cached snapshot across Heads. Subscription failures +clear stale data and reconnect with bounded 1–30 second backoff. Queries have +timeouts, and reload/removal/quit cancel and join old workers, kill/reap their +owned helpers, and close sockets. Set `:status-providers nil` explicitly to +remove all providers; omitting the option preserves the previous setting. +To inspect connection errors through SLY: + +```lisp +(lime.dev:with-development-backend (backend) + (lime.x11:backend-status-provider-report backend)) +``` + +Fast plain `(backend head-id)` provider functions returning `head-bar-segment` +values still work. They run during drawing, so must not perform blocking I/O +and do not schedule their own refresh. For a Lisp-only scheduled source, +`make-status-provider` accepts `:id`, `:run`, `:click-action`, and optional +`:formatter`, `:foreground`, and `:maximum-width`. Its worker function uses +`status-publish` (scalar/string/list data, or NIL for unavailable), +`status-wait` (interruptible deadline), and `status-cancelled-p`; it must honor +cancellation, never mutate the WM/backend, and never draw from its thread. +The built-in I/O sources additionally register short resource-cancellation +callbacks through the internal runtime boundary. + +Publication and formatting copy data trees, so mutating a producer's input or +a formatter's argument cannot change the worker cache. Formatters are never +called by the publisher. Generic providers default to the identity formatter, +so existing string-publishing providers continue to work. Reports expose both +`:value` (raw data) and `:text` (formatted output), plus source/formatter errors. +Changing a formatter on an existing provider can redraw the cache without +restarting its worker; evaluating new constructor objects during config reload +still replaces those providers using the normal lifecycle. + +## Fonts + +The bar and dropdown share one font setting, independent of window layouts: + +```lisp +(:font :family "monospace" :size 14 :weight :normal) +``` + +These are the defaults. `:size` is a pixel size (1–96), not points; `:weight` +is `:normal` or `:bold`. Family names are installed Fontconfig font families, +not X11 core-font names or Xft patterns such as `Dina:size=11`. +Comma-separated families give a preferred fallback order, for example: + +```lisp +(:font :family "Dina, Fira Code Nerd Font, Noto Color Emoji" + :size 15 :weight :bold) +``` + +Pango/Cairo supplies antialiasing, Unicode shaping, bidirectional text, and +system font fallback. Japanese, emoji (including color emoji), and Nerd Font +icons work when suitable fonts are installed. A missing family falls back +to a system font; a character missing from every installed font may still +show a missing-glyph box. Lime no longer converts Unicode to `?`. + +Font changes reload live, including an already-open dropdown. Its rows resize +to the font; the bar keeps its explicitly configured `:height`, so increase +that too for larger fonts. Fitting uses measured glyphs and truncates only at +grapheme boundaries, preserving combining accents and joined emoji. This is +rendering support, not an input-method/IME implementation. + +The first upgrade from the old core-font renderer changes native resources +and structure definitions: restart the Lisp/Xephyr test session once. Later +font **configuration** changes use the ordinary configuration reload. + +## Cursors + +The desktop arrow, clickable bar/menu hand, and cooperating applications share +a configurable Xcursor theme: + +```lisp +(:cursor :theme nil :size nil) ; defaults: follow the system +;; Or choose an installed theme and nominal pixel size explicitly: +(:cursor :theme "Adwaita" :size 24) +``` + +Use just one `:cursor` clause. `:theme` is a theme directory name, not a font +or file path; `:size` is an integer from 8 to 256, or NIL for automatic sizing. +Explicit config wins over `XCURSOR_THEME` / `XCURSOR_SIZE`, which win over the +current X screen's `Xcursor.theme` / `Xcursor.size` Xresources. No environment +variables are required. Without those, the theme is Xcursor's `default` +(including `default/index.theme` inheritance); size uses `Xft.dpi` when +available, otherwise 24px. The theme supplies its nearest available size. + +Installed cursor directories, `XCURSOR_PATH`, and theme inheritance are resolved +by libXcursor. A missing asset/theme may fall back to the system default theme. +If libXcursor, ARGB-capable X Render, or usable cursor images are unavailable, +Lime falls back to built-in X cursors. `:theme :core` requests those explicitly. +Inspect the selected settings and each role's source/fallback reason with +`(lime.x11:backend-cursor-report backend)`; the reported theme is the requested +search theme, not proof that an asset came from that directory. + +Theme images retain alpha and hotspots. Animated assets use X Render's server +animation support (or their first frame on older servers), not a WM timer. + +Explicit `:theme` / `:size` values also become **session-local application +defaults**. Lime publishes cursor-only XSETTINGS for GTK and compatible toolkits, +updates `Xcursor.theme` / `Xcursor.size` in the current X screen's resources, +and passes `XCURSOR_THEME` / `XCURSOR_SIZE` to programs launched through Lime. +You still configure these in Lisp; no environment setup is required. Lime does +not rewrite GTK/Qt files, dconf, the global launch environment, or another X +session. Application-specific cursors (text, resize, drag, etc.) retain their +roles; applications that deliberately override the theme can still do so. + +Lime never replaces an existing XSETTINGS manager and yields if one takes over. +The `:session` entry in `backend-cursor-report` reports `:published`, +`:external-manager`, or `:following-system` under `:xsettings`. With an external +manager, configure its cursor theme too if its toolkit settings disagree. + +Only explicit values are published: a NIL field follows its ordinary defaults. +Returning both fields to NIL, choosing `:theme :core`, or exiting Lime releases +its manager and restores the Xresources it still owns, preserving intervening +external edits. Some applications cache cursor settings and need reopening; +in particular, GTK 3 can retain a removed setting until restart even though +changes between explicit themes/sizes update live. + +After the initial structural upgrade/restart, theme/size changes reload live, +including a hovered widget or an open dropdown. New cursor resources are +prepared first; a later config failure restores the old resources, while a +successful reload releases them. Session publication participates in the same +rollback. No activity or view is recreated. + +## Bar appearance + +The bar has three regions: `Lime | activities | layout` on the left, +a left-aligned expanding title section, and optional right-aligned status +providers. Only the title section changes colors with Head focus. Its two +one-pixel edges are deliberately quieter than the colored text separators. + +Bar colors and padding can be reloaded without restarting or changing a saved View: + +```lisp +(:bar :height 22 :padding-x 10 + :background "#060a0c" :foreground "#ffdbb0" + :focused-background "#121f25" :focused-foreground "#ffac54" + :unfocused-background "#0b1216" :unfocused-foreground "#a8adb0" + :separator-color "#b88755" + :attention-color "#ffac54" + :attention-marker "!" :attention-indicator-p t + :title-edge-color "#40535d") +``` + +These are the defaults. Use `:title-edge-color nil` for the edge-free variant. +Use `:logo-color "#768565"` to color the clickable `Lime` label independently +of the Activity and layout labels. NIL (the default) inherits `:foreground`. +Optional `:accent-color` separates menu key hints, hover/selection markers, and +which-key headings from the focused title's foreground. `:menu-label-color` +separates submenu labels from the bar's separators. Both default to NIL to +preserve the old colors (`:focused-foreground` and `:separator-color`, +respectively; headings retain `:foreground`). For cream titles and labels +with yellow hints, add: + +```lisp +:focused-foreground "#dbc9a6" +:accent-color "#ffb054" +:menu-label-color "#dbc9a6" +``` + +These new roles and separately colored status prefixes require one fresh Lime +process when upgrading from the older renderer. Subsequent color-only config +edits can be reloaded normally. + +The attention indicator appears as `! N` ahead of the optional status widgets +only while windows request attention. It counts windows across **all** Activities +and appears on every visible Head bar, including when their Activity is parked. +Click it, or use `Super-y → w → a`, to search requesting windows by Activity +and current title. Activity-search details and hidden-window entries also mark +requests. No new global keybinding is installed. + +`:attention-color` and `:attention-marker` control that badge; the marker is +1–16 printable characters. `:attention-indicator-p nil` hides the bar badge, +not the protocol handling or menu. The public cached-data queries +`backend-attention-client-ids` (optional `:activity-id`) and +`backend-client-needs-attention-p` are available to custom Lisp UI/providers. +`backend-open-attention-picker` opens the picker, and `backend-attend-client` +performs the same visit without a menu (`:policy :strict` by default). +See [attention behavior](attention.md) for acknowledgement and lease rules. + +`:padding-x` is horizontal text padding in pixels (0–128): the outer left and +right margins and the title section's inset +inside its hairlines. The bar vertically centers a stable sample of the font's +letter body, rather than its invisible line spacing. All fields share a +baseline, so changing titles or adding descenders does not make text jump. +Accents and descenders retain their normal positions relative to that baseline; +increase `:height` if the chosen font or fallback glyphs need more room. + +Colors must be `#RRGGBB`; invalid settings fail before changing the running +configuration. A failed installation restores the old bar appearance along +with bindings and window styling. Lisp callers can use `MAKE-HEAD-BAR-STYLE` +and the configuration's `BAR-STYLE` slot directly. + +Status providers still supply their own text and optional click actions. +The bar draws contrasting ` | ` delimiters between their items; those +delimiters and truncation dots are not clickable. Appearance settings alone +do not enable providers; opt into the widgets above separately. Providers may use text, +Unicode symbols, or icons covered by the configured/fallback fonts. + +## Default layout + +`:options :default-layout` chooses `:master-stack` (the default), `:monocle`, +or `:manual` for a **new** working arrangement. This includes the initial +Scratch drafts, new Activities, and newly extended portions. Bringing or resuming +an existing draft or recalling a saved View keeps its layout. Reloading this +option changes future drafts only; it never rearranges your current work. + +The configuration is read before startup drafts are created. Without a config +file, `start-lime`/`start-backend` also accept `:default-layout`; with a file, +the file's setting wins. + +## New-window and close policy + +The `:options` clause also keeps client-flow preference out of the layout +engine. `:new-client-focus` controls whether ordinary newly managed windows +take focus. `:new-tiled-client-position` is `:back` (append after the existing +stack) or `:front` (become master-most). `:close-focus-direction` is +`:previous` (toward master in placement order) or `:next` (farther down the +stack); reaching either edge falls back to the closest client on the other +side. These are the fallback defaults for manual and master/stack: `t`, +`:back`, and `:previous`. + +Each layout can override only the flow choices it needs: + +```lisp +(:layout-flow :monocle + :new-tiled-client-position :front + :close-focus-direction :next) +``` + +That is Lime's built-in monocle policy already: each new tiled client becomes +the visible one, and closing it advances to the next underlying client. A +`:layout-flow` clause is useful when you want a different monocle cycle, or a +separate policy for `:manual` or `:master-stack`. + +## Resizing a window within a column + +Master/stack gives each tiled placement a relative weight, initially `1`. +Two windows weighted `2` and `1` take two-thirds and one-third of their column. +The master area and stack normalize separately, leaving their shared divider +unchanged. This also works with several master windows, and along the other +axis when the layout is rotated. + +Configure the commands and step size in your own keymap, for example: + +```lisp +(:command grow-tile + :label "Grow window in column" + :action (lambda (backend) + (lime.x11:backend-adjust-focused-tile-weight backend 1/4))) +(:command shrink-tile + :label "Shrink window in column" + :action (lambda (backend) + (lime.x11:backend-adjust-focused-tile-weight backend -1/4))) +(:command reset-tile-size + :label "Reset window column share" + :action (lambda (backend) + (lime.x11:backend-set-focused-tile-weight backend 1))) +(:bind #\d grow-tile :modifiers '(:mod-4 :shift)) +(:bind #\n shrink-tile :modifiers '(:mod-4 :shift)) +(:bind #\o reset-tile-size :modifiers '(:mod-4 :shift)) +``` + +The adjust command defaults to weights between `1/4` and `4`; callers can +override `:minimum-weight` and `:maximum-weight`. Reset affects the focused +window only. A sole window still fills its column. + +Weights belong to placements in the current draft and are checkpointed by +normal View save/update operations. They follow windows through tile moves, +float/unfloat, and layout changes. Monocle ignores the weights. Hiding removes +the placement; showing the window again creates a default-weight placement +unless a saved View restores its previous arrangement. + +## Borders and gaps + +The `:appearance` clause configures window styling independently of layout +policy. Sizes are non-negative integer pixels and colors are `#RRGGBB` strings. +`:inner-gap` is the space **between** tiled outer frames, not a margin on each +window; `:outer-gap` is the space between tiles and the Head's work-area edge +(below the bar). Border widths are included inside the allotted rectangle, +so they cannot make neighboring tiles overlap. + +The implementation lives in `src/x11/appearance.lisp`; the render planner +combines it with ICCCM hints, while your configuration owns the actual values. + +Only the globally focused client gets `:focused-border`; windows on other +Heads use `:unfocused-border`. Floating windows have borders but no tiling +gaps. Smart gaps remove both gaps and borders whenever a Head displays just +one tiled window, in manual, master/stack, or monocle. Floats above it keep +their borders and do not count as tiles; explicitly hidden clients and tiles +leased to other Heads do not count either. A second visible tile restores the +configured borders and gaps automatically. Monocle always resolves just one +tile, so it remains undecorated even with several clients in its cycle. +These tiles still respect the bar's work area and normal size hints. True +fullscreen bypasses decoration, the bar reservation, and size hints. Size hints may +leave additional unused space, but cannot enlarge a tile beyond its slot. +On very small tiles, excessive gaps/borders shrink to leave usable content. + +Changing these settings and reloading configuration repaints existing windows +without changing layout weights, saved Views, leases, or draft dirty state. +Setting a size to `0` disables that component. Without an `:appearance` clause, +the adapter retains its borderless/gapless defaults; default border colors +are white (`#ffffff`) and gray (`#444444`) if only a width is specified. + +## Reloading + +`lime.config:reload-configuration` rereads the source file selected at start. +It validates commands, bindings, rules, appearance, and bar inputs before changing the +running backend. If a subsequent installation operation fails, Lime restores +the previous binding set, appearance, and bar settings; Activities, Views, Presentations, +leases, and Viewsets are never re-created or changed by a reload. `:startup` +hooks run only at initial `start-lime`, never on reload. + +Because a config file is real Lisp, arbitrary top-level side effects are still +the author’s responsibility. Keep top-level work to helper definitions and +`defconfiguration`; place deliberate launches in a `(:startup (lambda +(backend) ...))` clause when that behavior is wanted. + +## Rules, deliberately for styling first + +`(:rule ...)` supports `:name`, `:class`, and `:title` matchers (a string or a +one-argument predicate), plus a full `:predicate` function of `(backend +client-id icccm-info)`. Its current actions are `:float t/nil` and `:center t`. +Centering requires floating. The first matching rule wins. + +Ordinary clients default to tiled, except fixed-size windows (equal positive +minimum and maximum width **and** height in `WM_NORMAL_HINTS`), which start +centered and floating. This handles startup/updater windows without floating +the application's resizable main window. A matching `:float nil` rule can +override that default. These defaults apply only when a client is first +managed; later hint updates do not reclassify existing placements. The usual +`:new-client-focus` setting applies to fixed-size ordinary clients too. + +Rules apply only to ordinary new clients. ICCCM transient dialogs keep their +parent’s Head, Activity, and float behavior; dialog-like EWMH clients retain +their floating policy too. Rules intentionally do **not** +mount a View, change an Activity, or transfer a lease: matching an application +class must not silently alter Lime’s task model. Activity-aware launch/routing +can grow later as a separate policy with explicit collision semantics. diff --git a/docs/development.md b/docs/development.md new file mode 100644 index 0000000..8eb9b91 --- /dev/null +++ b/docs/development.md @@ -0,0 +1,221 @@ +# Live development + +`lime/dev` is the safe route for hacking on a live Lime session. It keeps the +X11 event loop on one thread and starts a Slynk server bound only to +`127.0.0.1`. A connected REPL must send backend work through the developer +mailbox, so a source reload or command cannot race CLX event handling. + +It is intended for a nested Xephyr server or a separate X login/session. Do +not start Lime against the same X display already owned by dwm (or another +window manager): X11 permits exactly one root-window substructure redirect +owner. + +For the first non-nested test, keep your normal dwm login intact and use a +spare TTY/X server. A minimal `~/.config/lime/xinit-dev` can be: + +```sh +#!/bin/sh +exec sbcl --non-interactive --eval '(require :asdf)' \ + --eval '(asdf:load-asd "/home/adan/code/common-lisp/lime/lime.asd")' \ + --eval '(asdf:load-system "lime/dev")' \ + --eval '(lime.dev:run-development-session + :display-name (uiop:getenv "DISPLAY") + :config-file "/home/adan/.config/lime/config.lisp")' +``` + +Make that file executable, then start it from another TTY with +`startx ~/.config/lime/xinit-dev -- :1 vt8` (adjust the display/VT if either is +already in use). Connect SLY from your ordinary session, and keep that +ordinary session or a second TTY as your escape hatch. Launch test clients on +the new display with `DISPLAY=:1 your-client`, or put deliberate launch forms +in your configuration's existing `:startup` hook. + +## Start a session + +The configured `:default-layout` starts fresh Head-local drafts in master/stack +unless overridden. Existing drafts and saved Views keep their layouts on +configuration reload. The isolated regression test for startup, multi-head +first visits, adoption, and reload is: + +```sh +sbcl --non-interactive --load test/x11-default-layout-smoke.lisp +``` + +It requires Xvfb and creates its own test display. + +Floating drag regression (also on its own isolated Xvfb): + +```sh +sbcl --non-interactive --load test/x11-floating-smoke.lisp +``` + +This checks real Super-drag input, burst coalescing and release ordering, +checkpoint isolation, size hints/borders, and invalidated gestures. It also +compares full-desktop versus geometry-only update timings. Timing is diagnostic; +the regression asserts bounded rendering work rather than a hardware-dependent +frame rate. Restart once after the drag-state change; ordinary config reload +alone does not install the new code/structure. + +From the Lime checkout, start SBCL without `--non-interactive` so its process +remains available: + +```sh +sbcl --eval '(require :asdf)' \ + --eval '(asdf:load-asd "/home/adan/code/common-lisp/lime/lime.asd")' \ + --eval '(asdf:load-system "lime/dev")' \ + --eval '(lime.dev:start-development-session + :display-name ":1" + :config-file "/home/adan/.config/lime/config.lisp")' +``` + +The default Slynk endpoint is `127.0.0.1:4005`; connect Emacs/SLY to it. +For a nested test display, replace `:1` with your Xephyr display. The normal +Lime configuration is loaded before the event thread starts. + +Every live backend operation from that REPL should use the serialized boundary: + +```lisp +(lime.dev:with-development-backend (backend) + (lime.x11:backend-status backend)) + +(lime.dev:reload-development-configuration) +``` + +The second form preserves Activities, Views, Presentations, leases, windows, +and the current physical-Head mapping. It only reloads user policy such as +bindings, commands, rules, and bar providers. + +You can expose the same actions in your development configuration, which makes +the palette/key layer useful even before connecting a REPL: + +```lisp +(:command reload-lime-source + :label "Reload Lime source" + :description "Compile and install changed function-level Lime code" + :category "Development" + :action (lambda (backend) + (declare (ignore backend)) + (lime.dev:reload-development-code))) +(:command reload-lime-config + :label "Reload Lime config" + :description "Reload the active configuration without replacing the desk" + :category "Development" + :action (lambda (backend) + (declare (ignore backend)) + (lime.dev:reload-development-configuration)) +``` + +## Reload code without resetting your desk + +After a function-level source edit, evaluate: + +```lisp +(lime.dev:reload-development-code) +``` + +This compiles and loads changed files in `lime/x11`, reconciles the current +render plan, and returns a `development-reload-report`. A compile failure is +reported in that object and the existing event loop/world stay alive. + +Safe reload territory includes ordinary function changes: commands, layout +math, renderer code, palette behavior, bar drawing, and configuration helpers. +It deliberately does **not** promise structural live migration. Restart after +changing `defstruct` slots, package or ASDF topology, backend-thread ownership, +or `lime/dev` itself: + +```lisp +(lime.dev:restart-development-session) +``` + +A backend restart now saves/restores the desk through the display-specific +session file, enabled by default for `lime/dev`. Surviving windows reconnect +with verified identities, including hidden ones. With `:session-file nil`, it +still starts a fresh world. See [session persistence](persistence.md) for the +logout boundary, custom paths, safe writes, and error recovery. + +The supervisor and existing Slynk listener stay alive through a slow restart. +A failed pre-restart save retains the old X connection; repair and retry, or +resume the retained backend. If replacement backend startup fails after X has +closed, the control session stays paused: repair and call restart again, not +resume. Restart from an event-loop error uses the last good disk snapshot; +resume instead validates the retained in-memory world. + +Inspect the live runtime with: + +```lisp +(lime.dev:development-status) +``` + +When you are finished, use `(lime.dev:stop-development-session)` from the +control REPL. It stops the event thread before closing CLX, remaps managed +clients, and closes the Slynk listener. + +## Recovering from an event-loop error + +Use the supervised `lime/dev` launcher above for this behavior. The bare +`lime.x11:run-event-loop` API does not supply a recovery thread or REPL. + +Expected X11 client races (a window vanishing during adoption/property reads, +or becoming unviewable just before focus) are handled at the adapter boundary. +They increment `:expected-x-errors` in backend diagnostics; they do not pause +the desktop. Ownership conflicts and unrelated protocol/programming errors +are **not** silently ignored. + +An unexpected event-loop error pauses event dispatch, releases active keyboard +and pointer grabs, closes the command overlay, and preserves the X connection +and in-memory world. The original event is consumed, not automatically retried; +the remaining queue is retained. Slynk and the serialized mailbox stay alive: + +```lisp +(lime.dev:development-status) ; :paused-p, :last-error-report, etc. + +;; Repair the problem; function-level changes can still be loaded while paused. +(lime.dev:reload-development-code) + +(lime.dev:resume-development-session) ; explicit validation + reconciliation +``` + +Resume validates the core and adapter registrations, retires disappeared +clients, completes an interrupted MapRequest adoption if needed, and renders +the retained world. It does not replace Activities, saved Views, or drafts. +An invalid model, broken renderer, or closed connection leaves the session +paused and returns an error to the REPL. This is recovery, not transaction +rollback: inspect state after a partially completed command before continuing. + +While paused, **WM key bindings, menus, and new window management do not run**; +use SLY for repair/resume or `stop-development-session` for an intentional exit. +Existing application windows/processes are not deliberately destroyed. No +automatic resume loop is used, because replaying arbitrary partial mutations +can make a bug worse. + +Diagnostics retain the newest 32 reports in memory and overwrite one private +(mode `0600`) last-fault file under `$XDG_STATE_HOME/lime/`, normally +`~/.local/state/lime/last-error-.log`. Display punctuation becomes `-`; +for example `:1` becomes `last-error--1.log`. `development-status` returns the +exact path and any log-write error. Reports include time, event/window id, +condition, and an SBCL backtrace captured before unwinding. They omit backtrace +arguments, but error messages can still contain private paths/data; review a +report before sharing it. Pass `:diagnostic-file #p"/chosen/path.log"` to the +development launcher to override it, or `:diagnostic-file nil` for memory only. +A logging failure does not end the control session. + +This protects ordinary signaled event-loop errors, **not** native Lisp crashes, +process kills, deadlocks, or X-server failure. Disk session persistence is a +[separate layer](persistence.md), not a guarantee that application processes survive. +Initial startup failure before the developer session exists still reports a +normal launch error. Keep a TTY escape hatch during daily-driver testing. + +The resilience change adds backend/runtime slots: install it by stopping and +relaunching Lime in a fresh Lisp process once, not by reloading configuration. + +Isolated fault-injection regression (requires Xvfb and the `lime/dev` dependencies): + +```sh +sbcl --non-interactive --load test/x11-resilience-smoke.lisp +``` + +It creates its own display and private Slynk port, tests stale X requests, +mid-adoption death/failure, grab release, invalid-state rejection, diagnostic +write failure, slow failed restart/retry, and cleanup failure. It never connects +to the user's display or REPL. Test diagnostics remain in the printed temporary +directory for inspection. diff --git a/docs/model.md b/docs/model.md new file mode 100644 index 0000000..4015e7c --- /dev/null +++ b/docs/model.md @@ -0,0 +1,308 @@ +# Lime model + +This document is the source of truth for Lime's pure Lisp engine. The small +CLX adapter translates this model to X11; it does not redefine it. + +## Terms + +### Activity + +An Activity is a durable, named task container. It owns a pool of normal +clients and a library of saved Views. It is not a virtual desktop and it does +not intrinsically belong to one monitor or all monitors. + +Examples: `lime development`, `day job`, `game`. + +Every client has exactly one **home Activity**. A shared client additionally +has `client-shared-p` set: any Activity may request it, but it still receives +at most one global Lease. Sharing means availability, not sticky visibility, +cloning, or an automatic placement in every draft. `activity-client-ids` is +the home pool; `activity-available-client-ids` includes shared guests as well. + +`set-client-shared` changes this eligibility without granting leases. Making +a client private again removes its requests from foreign saved Views and +live/cached drafts, releasing any foreign lease. Home checkpoints survive; +the client is not automatically summoned home. + +`move-client-to-activity` changes home ownership and releases the current +lease. For private clients it prunes obsolete saved/cached/live references +outside the destination, including layout leaves and focus preferences. For +shared clients, valid saved requests survive; only the lease-holder's live +placement is removed. With `:target-head-id`, the placement is queued in the +destination's inactive working draft for that Head (preserving float geometry +and existing destination layout). Without it, the client is simply parked. +It never switches Heads or silently grants a lease in another active draft. +All removal/focus policy is prepared on copies before committing membership. + +`activity-deletion-summary` describes deletion without mutating the model. +`delete-activity` accepts only an Activity with no home clients and no mounted +Presentations on any Head. Hidden clients and shared clients borrowed elsewhere +still count as home clients: move or close them first. Deletion never closes +applications, switches Heads, or rehomes clients implicitly. + +Deletion removes the Activity's Views and cached/suspended drafts, prunes their +entries from Viewsets, and removes Viewsets left empty. Cached references to +shared guests disappear, but the actual guests retain their homes and leases +elsewhere. An optional `:expected-revision` protects a prior confirmation from +concurrent edits; all validation precedes mutation. There is no built-in undo. + +### View + +A View is a named, saved, **single-Head** checkpoint within an Activity. It +contains the desired visible client placements, Head-relative layout data, +and preferred focus. It is a definition, not a runtime owner of windows. + +Examples within `lime development`: `code`, `debug`, `docs`. + +An absent client means “this View does not request it on this Head”; it does +not mean “hide it everywhere in the Activity.” + +The concrete tiling representation is a binary tree of `layout-leaf` and +`layout-split` nodes. A split is horizontal or vertical and stores a relative +ratio. The tree contains exactly the View's `:tile` placements; `:float` +placements carry Head-relative geometry separately. + +A View or Presentation also records one layout policy: + +- `:manual` renders its explicit tree. Focused-split orientation/ratio edits + and slot swaps switch the live draft to this policy. +- `:master-stack` derives a conventional master area and equal stack from tile + placement order. Its options are `:master-count`, `:master-ratio`, and + master/stack `:orientation`; new tiled clients reflow under the same policy. +- `:monocle` retains the full tree and all leases, but renders only the focused + tiled client at the Head's full usable rectangle. Changing focus changes the + visible client without changing leases or the checkpoint. + +The policy and its options are snapshot data: they are copied into a +Presentation at activation and only reach a View through explicit save/update. +Floating is deliberately orthogonal to these tiling policies. A float stores a +complete `:x`, `:y`, `:width`, and `:height` rectangle as normalized fractions +of its owning Head; it therefore adapts to Head pixel dimensions without +putting X11 geometry in the model. `toggle-client-floating`, +`toggle-focused-client-floating`, and `set-client-floating-geometry` modify +only an active Presentation. Toggling a client back to tile returns it to the +current tiling policy; master/stack reflows, while the manual tree inserts a +new leaf. As with any live change, the rectangle reaches a View only through +an explicit save/update. + +### Head + +A Head represents one independently addressable display rectangle, normally a +physical monitor. A Head has zero or one active Presentation. Its pixel +rectangle is backend data: at X11 startup, RandR discovery normally derives +the non-overlapping rectangles from active CRTCs; explicit rectangles remain +available for nested servers and unusual arrangements. RandR change events +refresh the physical-topology snapshot. A caller then explicitly reconciles +the model's logical Head ids: a removed Head's live Presentation can move +intact to one chosen surviving/new Head, or suspend as an unbound cached draft. +No output event silently changes an Activity, View, or Lease. + +### Presentation + +A Presentation is one Activity's **current working arrangement on one Head**. +Together these arrangements form the Activity's live workspace across Heads. +There is at most +one working arrangement per `(Activity, Head)`, whether visible or inactive. +Recalling a View replaces that arrangement in place, not an extra cached +workspace. `Draft` means no source checkpoint, not a second navigation target. + +Switching away keeps the arrangement and releases its visible leases. +Returning restores current locations, unsaved windows, layout and focus. +Explicit moves/summons remove previous live locations, including inactive +ones; a later return cannot reclaim those windows. Hiding survives returns. +The low-level Head-local `open-activity-draft` operation creates an empty first +portion; it never gathers windows from another Head. Ordinary frontend +navigation adds a portable/extended policy above this operation. + +A **portable** Activity selects one working arrangement independent of its +physical Head. `bring-presentation-to-head` moves/resumes that arrangement; +if it is displayed elsewhere, it swaps with the target Head's current +arrangement. Active leases remain attached to their Presentation objects. +Hidden clients stay hidden, dirty layouts stay dirty, and checkpoints are not +recalled. The displaced Activity's cached portions transpose between the same +two Heads, preserving its full working state rather than overwriting a cache. +An inactive incoming arrangement changes only the destination's active selection. + +Explicitly extending an Activity enables independent Head-local portions. +This is navigation intent, not a second Activity type or a window-count rule; +closing/hiding the final window on a portion never automatically folds it. +The adapter persists this policy separately from the core world and can make +an Activity portable again after its other portions are empty and inactive. + +Only explicit checkpoint recall requests historical placements and offers +strict/partial/take policies. A partial recall may expose missing slots for an +explicit reclaim command, but Activity return drops those requests instead of +retrying them. Saved checkpoints never change through a move or partial recall. +Recalling a checkpoint on another Head detaches its older inactive source +label while preserving the old arrangement's remaining windows and layout. +When topology reconciliation suspends a draft from a removed Head, its +`head-id` is temporarily absent and it holds no leases; an explicit resume can +bind that draft to any current Head. + +### Lease + +A Lease is the exclusive, runtime-only right for one active Presentation to +show one real client. It is not persisted in a View. + +```text +client -> zero or one active Presentation lease +``` + +No lease means the client is parked. One lease means it is visible in that +Presentation. Two leases are invalid: a real X11 window is not a clone. + +### Viewset + +A Viewset is a deliberate whole-desk shortcut, not the default switching +behavior. It is a saved mapping of Heads to Activity/View selections: + +```text +Development + left -> Lime development / Code + right -> Lime development / Debug + +After work + left -> Game / Play + right -> Comms / Chat +``` + +Its activation uses its own preflight/plan/commit machinery, but validates all +target Heads together. A Viewset saves durable `Head -> View` selections—it +does not serialize mutable Presentations, drafts, focus overrides, or Leases. +Capturing the current desk therefore requires every selected Head to be mounted +from a saved View; save a View first when a Head holds an unsaved draft. + +All target Heads release their outgoing leases before any incoming View is +mounted. That makes a genuine swap safe: + +```text +before: left -> Code, right -> Play +after: left -> Play, right -> Code +``` + +Neither incoming View conflicts with the other’s outgoing lease or mounted +View. A client leased on an unselected Head remains an ordinary external +collision, resolved explicitly as strict, partial, or take. If two target Views +both request the same client, the Viewset is rejected as internally ambiguous; +Lime never chooses a winner based on entry order. + +## Invariants + +1. A client has exactly one home Activity; shared clients are eligible elsewhere. +2. Each Head has at most one active Presentation. +3. A named View has at most one active mounted Presentation. +4. A normal client has at most one Lease globally. +5. A Lease must point to an active Presentation in an eligible Activity + (home, or any Activity for a shared client), containing a placement for it. +6. A saved View never changes as a side effect of a lease collision. +7. Switching one Head changes only that Head unless an explicit operation + transfers a client lease, revokes sharing, or activates a named Viewset. +8. Each `(Activity, Head)` has at most one current working arrangement. +9. Each client has at most one current live location, even while undisplayed. + Missing slots from an explicit partial recall are not live locations. +10. A source checkpoint labels only one working arrangement. Saved View + definitions may still contain overlapping sets of windows. + +## Activation is a plan, not a UI monolith + +The core deliberately separates collision detection, resolution choice, and +state mutation: + +```text +preflight-view-activation + -> Activation Report: ready / conflicts + -> strict, partial, or take plan builder + -> commit-activation-plan +``` + +The menu is only one consumer of the report: + +```text +Docs needs Emacs, currently leased by Left / Code + +Open reduced -> build-partial-activation-plan +Move Emacs here -> build-taking-activation-plan +Go to Left -> frontend focus command +Cancel -> no plan +``` + +This lets the same semantics work from keyboard bindings, an on-screen menu, +IPC, or a Lisp REPL. + +### Viewset activation is a grouped plan + +```text +preflight-viewset-activation + -> Viewset Report: all selected Heads, outgoing group, conflicts + -> strict, partial, or take Viewset plan builder + -> commit-viewset-plan +``` + +The grouped preflight deliberately excludes leases and mounted Views held by +selected Heads’ outgoing Presentations, because the single commit releases all +of them first. It still checks stale world revision and every target Head’s +outgoing Presentation id immediately before mutation. + +## Topology reconciliation is a plan too + +RandR supplies the desired physical Head identifiers, but it never gets to +choose task routing. The separate core sequence is: + +```text +preflight-head-topology-reconciliation + -> Head Topology Report: retained / added / removed / live removed sources + -> build-head-topology-reconciliation-plan with explicit source -> destination moves + -> commit-head-topology-reconciliation-plan +``` + +An incoming move keeps the exact live Presentation, including its unsaved +layout, focus, and leases. If a surviving destination already has a live +Presentation, that destination becomes a normal cached draft and releases its +leases before the incoming Presentation mounts. A removed source omitted from +the move list becomes an unbound, lease-free cached draft instead. Added Heads +with no incoming move are genuinely blank; a normal Activity or View command +can mount something there later. + +## Collision behavior + +The normal strict command makes no change if a requested client is leased by a +different active Head. It does not silently use “last request wins.” + +Two explicit alternatives exist: + +- **Partial activation** mounts the View with free clients and records the + contested clients as unavailable slots. +- **Take activation** transfers the contested leases atomically to the target + Presentation. The source Presentation becomes temporarily incomplete; its + saved View remains unchanged. + +A newly freed client is never auto-awarded to another Presentation. An +explicit reclaim command fills an available slot, avoiding windows that jump +between monitors unexpectedly. + +## New windows and snapshots + +New clients join the focused Head's active Activity and live Presentation. +They do not retroactively appear in old saved Views. +`show-client-on-presentation` changes only the live draft; +`update-view-from-presentation` is +the deliberate checkpoint update operation. + +Updating a partially mounted/degraded Presentation is rejected by default so a +missing contested client cannot be silently erased from a reliable checkpoint. + +## Backend boundary + +The model knows nothing about X11, CLX, pixels, or an event loop. The backend +translates a committed logical transition into batched effects: + +```text +logical plan -> unmap / configure / map / stack / focus -> X11 +``` + +The backend must preserve the model's one-lease invariant and use X11 event +feedback only to update client lifecycle state. A permanently destroyed +client is retired from its Activity, saved Views, live/cached Presentations, +and lease; it cannot leave a phantom tiling slot behind. Layout trees, floating +geometry, Head work areas, RandR discovery and hotplug-migration policy, ICCCM/EWMH, and input binding +policy all belong above or below this core rather than inside lease resolution. diff --git a/docs/persistence.md b/docs/persistence.md new file mode 100644 index 0000000..4e334b0 --- /dev/null +++ b/docs/persistence.md @@ -0,0 +1,149 @@ +# Session persistence + +Lime saves the **desk**, separately from your Lisp configuration: Activities, +named Views and Viewsets, current and cached drafts, hidden/shown membership, +home Activity and shared eligibility, layout order/options/weights, floating rectangles, focus, dirty flags, partial +View state, and logical Head selections. It does not serialize CLX objects, +fonts, key bindings, callbacks, running processes, or application contents. + +`lime/dev` enables this automatically. The normal location is +`$XDG_STATE_HOME/lime/sessions/`, falling back to `~/.local/state/lime/sessions/`. +Files are separate for each DISPLAY (for example `display-_3A0.sexp` for `:0`, +`display-_3A99.sexp` for `:99`). Your nested test desk does not overwrite your +normal desktop's desk. A lifetime writer lock prevents two backends from using +one explicit file simultaneously. + +Select a different file or disable persistence with launcher keywords—not an +additional Lime environment variable: + +```lisp +(lime.dev:run-development-session + :config-file #p"/home/adan/.config/lime/config.lisp" + :session-file #p"/home/adan/.local/state/lime/my-desk.sexp") + +;; For a disposable test: +(lime.dev:start-development-session :display-name ":99" :session-file nil) +``` + +The lower-level `lime.x11:start-lime` / `start-backend` APIs default to no +persistence; pass `:session-file :default` or a pathname to enable it. An +explicit `:world` and a session file are mutually exclusive startup sources. +Configuration reload does not change the selected session file. +Configured startup hooks still run normally; hooks that create named Activities +should tolerate those Activities already existing in a restored desk. + +`scripts/run-xephyr-dev` supports `--session-file PATH` and `--no-session`. +Without either option it uses the display-specific default. + +## What a restart restores + +On a **Lime-only restart within the same X server**, surviving clients reconnect +to their Activities, checkpoints, and drafts—including unmapped hidden clients. +The adapter verifies a random server token plus each client's XID and random +window token. An XID, title, WM_CLASS, or PID alone is never enough: reused ids +must not attach an unrelated application's window to an old checkpoint. + +On **logout, reboot, or X-server replacement**, the names and non-client layout +settings survive, but the old windows do not. Missing clients are retired from +the saved arrangements; an empty View remains a named checkpoint. This first +version does **not** relaunch applications, restore terminal/browser contents, +reserve placeholder slots for dead windows, or guess how newly launched +windows should fill an old arrangement. Application/session-relaunch rules are +a separate feature. + +Current physical Heads remain authoritative. Matching logical Head ids resume +their saved selections. Drafts from removed Heads are suspended, not moved to +an arbitrary other monitor or deleted; new Heads get ordinary blank drafts. +Viewsets retain their logical mappings even when an output is absent. Leases +are reconstructed and validated, never accepted as serialized ownership objects. + +## Saving and failures + +Autosave observes model/focus changes on the owner thread. After 750 ms of +quiet, or five seconds of ongoing edits, it captures a validated plain-data +snapshot. Active pointer drags postpone capture until release. A single worker +writes snapshots off the X event thread, keeping only the latest pending one. +An unchanged desk produces no disk writes. A crash can lose edits since the +last completed autosave; this is a snapshot system, not a per-operation journal. + +Normal shutdown flushes the final valid desk. A normal developer restart saves +**before closing X**; if that save fails, restart aborts with the old backend +still available for repair. Restart after an event-loop fault instead uses the +last good disk snapshot, avoiding an automatic save of partially mutated state. +`resume-development-session` still uses the retained in-memory world, not disk. + +For an explicit flush or inspection from SLY: + +```lisp +(lime.dev:save-development-session) +(lime.dev:with-development-backend (backend) + (lime.x11:backend-session-status backend)) +``` + +The status includes the file, restore/missing-client report, last-save time, +submitted/completed write generations, and restore/snapshot/write errors. Disk +write failures are nonfatal to ordinary operation and retry with five-second +backoff; explicit flush reports the error to its caller. Invalid in-memory +snapshots block automatic saving until repaired and explicitly saved again. + +Files are mode `0600`. Writes use a private temporary file in the same +directory, file `fsync`, atomic rename, and directory `fsync` on Linux. A failed +write before rename leaves the old file untouched; readers cannot see a partial +replacement. The format is versioned, bounded plain data. Reading never calls +`load`/`eval`, disables read-time evaluation, and rejects reader dispatch, +circular structures, excessive nesting, and trailing data. Unknown versions, +invalid relationships, duplicate leases, or malformed files are rejected before +replacing the startup world. + +A rejected file is **not overwritten**: Lime starts a fresh usable desk with +autosave blocked and reports the error. Inspect/back up the file first. To +deliberately replace it with the current desk: + +```lisp +(lime.dev:save-development-session :replace-invalid-p t) +``` + +This does not override another session's file lock. Stop that other session or +choose a different path. Back up important files separately; atomic writes are +not a backup/history system. Names and window associations can be private even +though the file contains no application buffers or process contents. + +## Installing and testing + +Membership support adds a client structure slot and ASDF components. Relaunch +Lime in a fresh Lisp process; configuration reload alone cannot install it. +World snapshots use schema version 3. The X11 session envelope uses +version 3, with ordered Activity positions, stable local-View shortcut slots, +last-arrangement history, and portable/extended Activity navigation policy. +Version-1/2 envelopes remain readable. Old Activities with one substantive +arrangement become portable; genuinely split arrangements remain extended. +This inference happens before missing-client pruning, preserving multi-monitor +intent across reboot. Old empty drafts are retained, not recalled or deleted. +Version-1 envelopes also receive initial shortcut assignments. Migration does +not move a window or alter what the Heads display. Navigation metadata is +validated before a saved world is installed. An explicit extended choice stays +extended when all its windows close; it is never re-inferred from window count. +Version 1 worlds load with all clients private. Version 1/2 worlds consolidate +historical drafts into one current arrangement per Activity/Head. Active state +wins, then saved navigation history, then the newest generated Presentation +id. Actual leases win duplicated window locations; missing checkpoint slots +are not live locations. Windows and saved Views are retained, and old source +labels are detached where a checkpoint was recalled elsewhere. Migration is +performed on a candidate world before installation; version 3 rejects duplicate +live locations rather than silently repairing them. Keep a backup before +upgrading or downgrading; older Lime builds may not read these schema versions. +The same-X-server identity rules above still apply to moved/shared clients. + +```lisp +(asdf:test-system "lime/persistence") +``` + +```sh +sbcl --non-interactive --load test/x11-persistence-smoke.lisp +sbcl --non-interactive --load test/x11-membership-smoke.lisp +``` + +The smoke test uses its own Xvfb, temporary state files, and fake client windows. +It tests graceful/abrupt restart, hidden clients, dirty checkpoints, partial +leases, changed topology/identity, corrupt files, disk failures, and the actual +developer restart path. It does not connect to your running desktop. diff --git a/docs/xephyr-demo.md b/docs/xephyr-demo.md new file mode 100644 index 0000000..82a41b1 --- /dev/null +++ b/docs/xephyr-demo.md @@ -0,0 +1,686 @@ +# Xephyr demo + +`lime/x11` is Lime's first deliberately small adapter from the pure +Activity/View/Presentation/Lease model to real X11 operations. It exists to +make the model visible and testable early. It is not a complete X11 window +manager yet. + +## Run it safely + +Use a clean nested X server. Do not run the prototype on the same root window +as an existing window manager: X11 allows only one client to select +`SubstructureRedirect` on a root window. + +```sh +Xephyr :99 -ac -screen 1000x700 -br -nolisten tcp +``` + +In a second terminal, in the repository root, start Lime in a Lisp image with +Quicklisp, CLX, Babel, and CFFI available. Install the native Pango/Cairo +libraries (including PangoCairo) and your desired fonts first: + +```lisp +(ql:quickload '(:clx :babel :cffi)) +(asdf:load-system "lime/x11") +(lime.x11:run-demo :display-name ":99") +``` + +For a user-owned configuration file instead of the starter map, load the same +system and start through `lime.config:start-lime`: + +```lisp +(lime.config:start-lime + :display-name ":99" + :config-file #P"/home/adan/.config/lime/config.lisp") +``` + +The configuration file interface, command registry, reload behavior, and +initial floating rules are documented in [Configuration](configuration.md). + +In a third terminal, create some clients: + +```sh +DISPLAY=:99 xterm +DISPLAY=:99 xterm +``` + +For two clients the fallback layout divides the 1000px-wide server into two +500px columns below Lime's default 22px Head bar. When either client exits, +the other immediately occupies the full usable width. This was exercised +against Xephyr during implementation. + +## Read the first Head bar + +Every Head owns a small persistent top bar. Its initial left-to-right shape is +roughly: + +```text +Lime | chill work code | []= focused window title music | volume | clock +``` + +The local Activity is highlighted. Saved Views are checkpoints recalled from +the menu, not nested workspaces, so there is no View/Draft/dirty suffix. `[]=` is +master/stack, `|M|` is the retained manual tree, and `[N]` is monocle with `N` +tiled clients in its stack, including the visible one. Hidden Activity clients +and clients leased elsewhere are excluded. Individual floats do +not change that token; Lime has no fake all-floating layout. The expanding, +left-aligned title section has quiet one-pixel edges on both sides. Its +background and text colors identify the focused Head, without a center +underline or a redundant "left Head" or "right Head" label. + +The fields use actual font measurements rather than fixed-width columns. +The left fields use measured, contrasting ` | ` separators; long names, +titles, and status text are shortened to fit their pixel budgets. Click +targets follow the displayed text, excluding status separators and ellipses. +The right-hand music/volume/clock above are illustrative providers, not built-in +integrations. Bar colors, including optional title edges, live in `(:bar ...)`. + +Titles prefer UTF-8 `_NET_WM_NAME`, then Latin-1 `WM_NAME`, then the client +class/name or "Untitled window". Property notifications refresh the bar +immediately. The shared Pango/Cairo renderer preserves Unicode, shapes text, +and uses system font fallback, including color emoji when installed. Configure +both the bar and dropdown with `(:font :family "monospace" :size 14 :weight +:normal)`; size is in pixels. Long text is shortened at grapheme boundaries, +not in the middle of an accented character or joined emoji. See +[font configuration](configuration.md#fonts) for family lists and live reload. + +Normal tiles and floats use the client work area below the bar. A real EWMH +fullscreen client takes the whole physical Head and hides its bar. Click +`Lime` to open the same Activity/View palette as `Super-y`; click the layout token to cycle +master/stack and monocle. Manual remains available through Lisp and saved Views, +but is hidden from the everyday cycle and layout menu. The palette is a dropdown below the bar, so +the current Activity stays visible while searching. + +The right side has no built-in shell commands. Configure optional status +providers in Lisp instead: + +```lisp +(lime.x11:backend-set-head-bar-status-providers + *lime* + (list (lambda (backend head-id) + (declare (ignore backend head-id)) + (lime.x11:make-head-bar-segment :id :clock :text "12:34")))) +``` + +Each provider receives `(backend head-id)` and may return one segment or a +list. A segment can also carry a `:click-action` function of those same two +arguments. + +## Exercise Activities and Views from the REPL + +The first control surface is intentionally Lisp-first. Start the backend in +the REPL and give its event loop a background SBCL thread: + +```lisp +(defparameter *lime* (lime.x11:start-backend :display-name ":99")) +(defparameter *lime-event-thread* + (sb-thread:make-thread (lambda () (lime.x11:run-event-loop *lime*)))) +``` + +Now the initial task workflow is directly usable: + +```lisp +;; 1. A fresh named task with a blank unsaved live draft. +(lime.x11:backend-start-activity *lime* "wm" "WM project") + +;; 2. Launch clients with DISPLAY=:99; they enter the WM project draft. + +;; 3. Capture the current arrangement as a checkpoint. +(lime.x11:backend-save-view *lime* "wm-code" "Code") + +;; 4. Arrange through the model, then capture a second checkpoint. +(lime.x11:backend-set-layout-root *lime* my-debug-layout) +(lime.x11:backend-save-view *lime* "wm-debug" "Debug") + +;; 5. Recall either View. The selected policy is explicit. +(lime.x11:backend-activate-view *lime* "wm-code" :policy :strict) +(lime.x11:backend-activate-view *lime* "wm-debug" :policy :partial) + +;; 6. Inspect the active Head without digging through structures. +(lime.x11:backend-status *lime*) +``` + +`backend-update-view` deliberately overwrites an existing checkpoint from the +live draft. `backend-resume-presentation` restores a cached draft by id; both +accept the same `:strict`, `:partial`, and `:take` collision policies where +they apply. Every transition applies the resulting Presentation to X11 before +returning. + +If a REPL or future IPC client only has a human-facing name, these helpers make +the same palette workflow available without hand-writing an id: + +```lisp +(lime.x11:backend-start-named-activity *lime* "WM project") +(lime.x11:backend-save-named-view *lime* "Code") +``` + +They derive readable unique ids and make the saved View current, so the normal +`backend-update-current-view` command follows the new checkpoint. + +## Capture and recall a whole-desk Viewset + +A Viewset is the explicit multi-Head companion to a single-Head View. It saves +the current `Head -> saved View` mapping, then later recalls every named target +as one atomic transition: + +```lisp +;; Every selected Head must currently be mounted from a saved View. By default +;; this captures all configured Heads in display order. +(lime.x11:backend-save-named-viewset *lime* "Work desk") + +;; Later, recall every mapped Head together. +(lime.x11:backend-activate-viewset *lime* "work-desk" :policy :strict) +``` + +`backend-save-viewset` accepts an explicit id/name and optional `:head-ids` +when you deliberately want a subset. It never serializes the live draft; save +the relevant View first if a Head has unsaved changes. Viewset recall uses the +same `:strict`, `:partial`, and `:take` vocabulary as View recall, but checks +the selected Heads as one outgoing group. That is what makes a saved left/right +swap work without briefly duplicating a View or lease. A client held by an +unselected Head can be left there (`:partial`) or deliberately taken (`:take`). +Two target Views that request the same client are rejected as an ambiguous +Viewset—Lime will not pick one based on ordering. + +`bind-viewset-key` is the corresponding opt-in Lisp configuration helper: + +```lisp +(lime.x11:bind-viewset-key *lime* #\w "work-desk") +``` + +The focused client is also saved on the live Presentation. Focus a particular +visible client or cycle its leased clients without exposing raw CLX calls: + +```lisp +(lime.x11:backend-focus-client *lime* "x11-...") +(lime.x11:backend-focus-next-client *lime*) +(lime.x11:backend-focus-previous-client *lime*) +``` + +`backend-status` includes `:focus-client-id`. The renderer sends X input focus +to that registered visible client after it maps all windows; a blank selected +Head focuses the root window instead. + +## Use built-in layouts and manual tree edits + +Layout policy belongs to the active Head-local Presentation, so it is an +unsaved draft change until `backend-save-view` or `backend-update-view` is +called. The first built-ins are master/stack and monocle: + +```lisp +;; First tiled client is the 60% left-hand master; the rest share the stack. +(lime.x11:backend-use-master-stack-layout + *lime* :master-count 1 :master-ratio 3/5 :orientation :horizontal) + +;; Promote the selected Head's focused tiled client to the master slot. +(lime.x11:backend-promote-focused-client *lime*) + +;; Full-Head focus mode. Other tiled clients remain leased but are unmapped. +(lime.x11:backend-use-monocle-layout *lime*) +(lime.x11:backend-focus-next-client *lime*) ; shows the next client in monocle + +;; Return to the retained binary tree, then edit the focused client's nearest +;; split. These actions deliberately make the draft :MANUAL. +(lime.x11:backend-use-manual-layout *lime*) +(lime.x11:backend-orient-focused-split *lime* :vertical) +(lime.x11:backend-resize-focused-split *lime* 1/20) +(lime.x11:backend-swap-focused-client *lime* :direction :next) +``` + +`backend-status` exposes `:layout-mode` and `:layout-options` for UI/IPC +frontends. The optional starter map below covers everyday commands; the named +helpers add task and physical-output shortcuts without hard-coding them. + +## Float a client and use Super-drag + +Floating is placement state, not a second kind of client or lease. Toggle the +focused client, then optionally set an exact Head-relative rectangle: + +```lisp +(lime.x11:backend-toggle-focused-client-floating *lime*) + +;; All values are normalized fractions of the selected Head. +(lime.x11:backend-set-client-floating-geometry + *lime* "x11-..." :x 1/5 :y 1/6 :width 3/5 :height 2/3) + +;; The same generic operation is useful to a future menu or IPC client. +(lime.x11:backend-toggle-client-floating *lime* "x11-...") +``` + +The renderer places visible floats above tiled content. `backend-status` +includes `:floating-client-ids`; save or update the active View to make a +float checkpoint durable. + +On a floating client, hold Super (`Mod4`) and use Button1 to move or Button3 +to resize. Super+Button2 toggles the clicked client's floating placement, the +same way as Super+Space. The adapter converts each root-pixel drag motion into +the same normalized geometry command above. Super-drag only claims floating +clients; on a tiled client it simply focuses the window and changes no geometry. + +## Click to focus + +An unmodified Button1 anywhere in a managed client's window tree selects the Head leasing it +and focuses that client, then the press is replayed to the application. Button1 on a blank part of the root selects the Head under the pointer +and focuses root, while retaining that Presentation's saved client-focus target +for later keyboard cycling or another client click. A background click is thus +not a View edit. + +The initial pointer policy reserves Super+Button1/2/3 for float move/toggle/ +resize. Menus, focus-follows-pointer, button rebinding, and robust Caps/Num- +Lock modifier normalization remain separate future policies. + +## Inspect ICCCM client facts or close a client + +`x11/icccm.lisp` tracks the conventional title, resource name/class, +`WM_PROTOCOLS`, InputHint, transient parent, and normal size hints for every +managed client. This data stays out of the Activity/View model and is available +to a future UI: + +```lisp +(let ((client-id (first (getf (lime.x11:backend-status *lime*) :client-ids)))) + (lime.x11:backend-client-icccm-info *lime* client-id)) + +;; Sends WM_DELETE_WINDOW when supported; only legacy clients use XKillClient. +(lime.x11:backend-close-focused-client *lime*) +``` + +Focus now honors ICCCM's InputHint and sends `WM_TAKE_FOCUS` when a client +advertises it. When Lime denies a tiled client's ConfigureRequest, it restores +the model geometry, adjusted to its cached normal hints, and sends that client +a synthetic ConfigureNotify response. + +When a lease makes a client visible Lime publishes `WM_STATE` `NormalState`; +when a View hides it, Lime publishes `IconicState` while retaining the client +in its Activity. Those renderer-originated unmaps are tracked explicitly. +If the application later unmaps itself, Lime recognizes the distinct ICCCM +withdrawal, removes `WM_STATE`, and retires that client from its Views. + +## Fullscreen and small EWMH compatibility + +`Super-f` follows your dwm binding and toggles true fullscreen for the focused +client. It also responds to a client's `_NET_WM_STATE_FULLSCREEN` request, +including the initial state a game publishes before mapping. The fullscreen +window receives the entire rectangle of the Head holding its exclusive Lease, +is raised above the other windows on that Head, and becomes the input focus. +Normal size hints intentionally do not constrain that fullscreen rectangle. + +Fullscreen is temporary EWMH adapter state, not a saved View edit. Switching +to a different View hides the game through its normal Lease; returning to the +View restores fullscreen on whichever Head legally holds that Lease. A second +fullscreen request on the same visible Head replaces the first. Lime also +advertises and handles `_NET_ACTIVE_WINDOW` for already visible clients and +`_NET_CLOSE_WINDOW`; it publishes `_NET_ACTIVE_WINDOW` while it controls +focus. Lime also creates the required `_NET_SUPPORTING_WM_CHECK` window and +keeps `_NET_CLIENT_LIST` plus `_NET_CLIENT_LIST_STACKING` current, so ordinary +desktop tools can identify the WM and enumerate its clients. It deliberately +does **not** implement fake numbered EWMH desktops. + +`_NET_WM_WINDOW_TYPE_DIALOG`, `UTILITY`, and `SPLASH` receive the same +centered floating/focus behavior as a transient dialog when no +`WM_TRANSIENT_FOR` parent exists. `DOCK` and `DESKTOP` windows are mapped at +their application-supplied geometry but never become Activity/View task +clients. External dock struts are intentionally a later work-area pass. + +## Dialogs and normal size hints + +When a newly managed window declares `WM_TRANSIENT_FOR` for a client Lime is +already managing, it follows that parent’s active Presentation and Head rather +than the most recently selected Head. Lime adds it as a float, centers it over +the parent, and focuses it. The dialog is still a normal placement and lease, +so it disappears/restores with the same View rules as every other client. + +Before every X11 configure, Lime applies the client’s `WM_NORMAL_HINTS` +minimum/maximum size, base-size, and resize increments. This includes tiling, +direct float geometry commands, and every Super-resize motion. The requested +Lime rectangle remains model state; the final client-compatible pixel rectangle +is adapter-local, so client constraints never mutate a saved View. If a client +demands more than the whole Head, Head containment wins. + +## Exercise two independent Heads + +On a normal X11 session, `start-backend` uses RandR automatically. Every active +CRTC becomes a Lime Head named after its representative output (for example, +`DP-1` and `DP-3`). Mirrored outputs sharing one CRTC deliberately become one +Head, so Lime never renders the same task rectangle twice. Inspect the live +hardware snapshot with: + +```lisp +(lime.x11:backend-randr-status *lime*) +``` + +Xephyr normally exposes one virtual output, so explicit rectangles remain a +useful way to exercise two independent Heads in the nested demo. This +1000×700 server becomes a left and right 500×700 Head: + +```lisp +(defparameter *lime* + (lime.x11:start-backend + :display-name ":99" + :heads + (list + (lime.x11:make-x11-head :head-id "left" + :x 0 :y 0 :width 500 :height 700) + (lime.x11:make-x11-head :head-id "right" + :x 500 :y 0 :width 500 :height 700)))) +``` + +Each configured rectangle receives its own active Presentation: initially an +unsaved, blank `Scratch` draft rather than a fabricated empty View. A saved +View is never mounted on two Heads, while two Head-local drafts may show the +same Activity when their exclusive window leases do not collide. Set the +temporary routing target before opening a window for a different Head: + +```lisp +;; Keep the existing Scratch task on the left. +(lime.x11:backend-start-activity *lime* "game" "Game" :head-id "right") +(lime.x11:backend-select-head *lime* "right") + +;; A subsequent DISPLAY=:99 client joins Game on the right. +(lime.x11:backend-status *lime* :head-id "left") +(lime.x11:backend-status *lime* :head-id "right") +``` + +`backend-select-head` selects the routing target and applies that Head's +saved focus target as real X input focus. Head rectangles must be positive, +inside the X root, and non-overlapping. Explicit `:heads` always takes +precedence over discovery; pass `:head-discovery :none` to force the old +single-root fallback instead. + +Lime subscribes to RandR screen/CRTC/output notifications for a discovered +startup. An event only refreshes the observed topology and marks it pending: +it will never silently decide where an Activity, View, or Lease should go when +a monitor is unplugged. `backend-refresh-randr-heads` safely applies a +resolution/position change when the same Head ids remain; an added or removed +Head returns `:reason :topology-changed`. For that case, keep observation, +choice, and mutation separate: + +```lisp +;; Read-only data for a future palette, IPC client, or REPL inspection. +(defparameter *randr-change* + (lime.x11:backend-randr-topology-report *lime*)) +(getf *randr-change* :removed-active-sources) + +;; Example after DP-3 disappears: keep its exact live draft on DP-1. +;; Omit a removed source from :MOVES to suspend its draft and release leases. +(defparameter *randr-plan* + (lime.x11:backend-build-randr-topology-plan + *lime* + :moves + (list (lime.core:make-head-topology-move + :from-head-id "DP-3" :to-head-id "DP-1")))) + +;; Rereads RandR, rejects a physically stale plan, then renders the result. +(lime.x11:backend-apply-randr-topology-plan *lime* *randr-plan*) +``` + +An added Head without an incoming move is blank. Select it, then use the +ordinary palette or `backend-start-named-activity` / `backend-activate-view` +commands to put the task you actually want there. + +## Watch a cross-Head lease collision resolve + +With two clients on the left Head, save two overlapping checkpoints from that +Head and ask to mount one on the right: + +```lisp +(lime.x11:backend-save-view *lime* "code" "Code" :head-id "left") +(lime.x11:backend-save-view *lime* "docs" "Docs" :head-id "left") + +;; Read-only: returns an ACTIVATION-REPORT with :CLIENT-LEASED conflicts. +(lime.x11:backend-preflight-view-activation *lime* "docs" :head-id "right") + +;; "Open what is available": left stays visible; right records holes. +(lime.x11:backend-activate-view-partially *lime* "docs" :head-id "right") + +;; "Move windows here": explicit transfer; the old left draft becomes partial. +(lime.x11:backend-activate-view-taking *lime* "docs" :head-id "right") +``` + +`backend-activate-view-strictly` is the default “open only if complete” +command: it signals `activation-blocked` rather than changing either Head if +any lease conflicts. The preflight function does no mutation; a future menu +can inspect its report, offer the complete, partial, and move-here commands, +or cancel. The adapter applies all configured Heads after a transition, so +an explicit take unmaps/reconfigures the source and target in one visual +update. + +## Install the starter keymap and name your own task shortcuts + +`start-backend` (and therefore `run-demo`) installs a Super (`Mod4`) keymap +for ordinary window operations. It has no Activity, View, or physical Head +names, so it does not guess at your workflow. Reinstall it after clearing or +changing bindings, or opt out at startup for a fully custom map: + +```lisp +;; Reinstall with a different primary modifier. +(lime.x11:install-default-keybindings *lime* :modifiers '(:mod-1)) + +;; Or start with no defaults and bind everything yourself. +(lime.x11:start-backend :display-name ":99" :install-default-keybindings-p nil) +``` + +| Binding | Command | +| --- | --- | +| Super-t / Super-h | Focus next / previous visible client | +| Super-Shift-t / Super-Shift-h | Move focused tiled client forward / backward | +| Super-Return / Super-z | Promote focused client / focus primary tiled client | +| Super-Tab / Super-Shift-Tab | Cycle master-stack ↔ monocle forward / backward | +| Super-d / Super-n | Shrink / grow master area (master-stack only) | +| Super-Up / Super-Down | Add / remove a master client (master-stack only; minimum one) | +| Super-Space | Toggle focused client floating | +| Super-f | Toggle focused client fullscreen | +| Super-i / Super-Shift-i | Show a hidden/shared window / hide the focused window | +| Super-Shift-c | Close focused client | +| Super-Shift-q | Quit Lime cleanly | +| Super-Shift-s | Update the mounted saved View from its live draft | +| Super-p | Open fuzzy PATH-program picker | +| Super-y | Open the Activity/View command palette | +| Super-e / Super-Shift-e | Select next Head / send focused client to next Head | + +`Super-Shift-i` parks the focused window only from the current Head-local +draft: it does not close, minimize, or remove the client from its Activity. +`Super-i` opens a fuzzy list of parked Activity windows plus shared windows and reveals the +chosen one in the current draft. If the window is presently visible on a +different Head, Lime asks for an explicit **Move here** confirmation rather +than showing one X11 window twice. Saving or updating a View records its +current shown/parked set, so this is the everyday way to keep a focused +monocle or tiled context uncluttered without inventing another workspace. + +Under `Super-y → w` (Windows), `m` moves the focused window to an existing +Activity. Create one first through `a → n` if needed. The move keeps you here +and queues the window in the destination's working draft for this Head; opening +that Activity shows it. A private window is removed from its old checkpoints +and cached drafts, so recalling them cannot pull it back across Activities. +Another Head already displaying the destination Activity is not rearranged. + +`Super-y → w → s` makes the focused window shared. It keeps one home Activity, +but becomes available through `Super-i` in every Activity. It does not appear +everywhere automatically. If another Head leases it, the picker offers an +explicit **Move here**; shared slots taken away can be summoned back using +the same picker. Views may save shared placements, subject to normal lease +conflicts on recall. On a shared window, `w → s` instead offers **Make private to +Activity**: the Activity where you're using it becomes its home. The window stays +on this Head, with the same position and focus. Saved views in this Activity keep +it; references in every other Activity (including its old home) are removed. +The confirmation names the Activity and defaults to Cancel; choose the named +action with arrows and Enter, or click it. Changing the desk while the prompt is +open invalidates the choice rather than acting on a different window or Activity. + +`Super-Shift-e` (or `Super-y → h → s`) sends the focused window to the next +Head. Same-Activity and shared-window transfers happen immediately, without +changing home membership. For a private window crossing Activities, the +dropdown names both Activities and offers **Cancel** (default) or **Move to +destination**. Choose with arrows and Enter, or click; Escape cancels. The +warning explains that moving removes the private window from its old saved +views. Changing the desk while this confirmation is open invalidates it. +Neither Head switches Activities; keyboard focus follows the window automatically, +so you don't need a second `Super-e`. `Super-e` still switches monitors without +moving a window. The destination selects the arriving +window in its arrangement, so it is visible even in monocle. A destination View or +draft that already contains the client controls the placement there; otherwise +Lime creates an unsaved destination placement matching the source tile/float +kind. The old Head loses the client and focuses a surviving window. The low-level +`backend-transfer-focused-client-*` functions remain strict, non-prompting lease +transfers; `backend-rehome-client-to-head` is the separate explicit rehome API. Lime +does not yet have dwm's all-floating layout; floating remains per-client. +The retained manual tree is accessible through Lisp and existing Views, +not through the everyday layout cycle. + +For names that only you can choose, use the configuration helpers. The strict +View policy below is safe by default; a future picker can use the same +preflight result to offer partial or take alternatives: + +```lisp +;; Super is normally Mod4 on X11. +(lime.x11:bind-head-key *lime* #\1 "left") +(lime.x11:bind-head-key *lime* #\2 "right") + +;; A View binding chooses an explicit collision policy. +(lime.x11:bind-view-key *lime* #\d "docs" :policy :strict) + +;; A Viewset binding atomically applies its saved Head -> View mapping. +(lime.x11:bind-viewset-key *lime* #\w "work-desk" :policy :strict) + +;; Without :VIEW-ID this resumes the Activity's unsaved Head-local draft, +;; creating a blank draft on that Head when needed. +(lime.x11:bind-activity-key *lime* #\g "game" :view-id "play") + +(lime.x11:list-keybindings *lime*) +(lime.x11:clear-keybindings *lime*) +``` + +Handlers that signal an error—such as a strict activation blocked by a +lease—do not kill the event loop. Inspect `backend-last-command-error` from +the REPL, and use `clear-keybindings` during reconfiguration. `bind-key` +remains available for arbitrary commands. The first pass matches modifier +state exactly, so Caps Lock/Num Lock tolerance and an actual focus policy +remain later input-layer work. + +## Open the first command palette + +Press Super-y to open a which-key-style command map below the bar. It shows +only the current prefix's keys in a compact grid; `+` labels are submenus. +Press a shown key to enter a group or run a command. Space or Tab opens direct +search; type to filter, use Up/Down to select, and Enter to run. Tab in search +returns to the root map. Escape closes in every mode. Super-p remains the +separate fuzzy program launcher. This is a real X11 overlay with a temporary keyboard grab, +not a managed client, so it is local to the currently focused Head and does +not affect client leases by itself. +The launcher reuses its executable catalog while PATH directories are unchanged; +rapid typing immediately after the shortcut is queued for the picker, not sent +to the previously focused application. The isolated `test/x11-launcher-smoke.lisp` +checks complete shortcut-plus-query-plus-Enter bursts and keyboard error cleanup. + +The direct-search catalog includes `New named Activity...`, `Save current +arrangement as View...`, and—when every configured Head has a saved source +View—`Save current Heads as Viewset...`. Press Enter on either to enter a one-line name prompt; +Enter confirms it and Esc cancels it. A named Activity opens a blank unsaved +live draft; it owns no permanent View until you save a meaningful checkpoint. +Saving a View checkpoints the live draft and mounts that new checkpoint, so +Super-Shift-s subsequently updates the View you just named. +Lime derives readable durable ids (`WM Project` becomes `wm-project`; `Code` +within it becomes `wm-project/code`) and adds a numeric suffix if needed, while +keeping your original title as the display name. + +If RandR reports an added or removed Head, the searchable catalog also +contains `Reconcile changed displays...`. Selecting it asks once for every +live Presentation on a removed Head: move it to one of the discovered Heads, +or `Suspend safely`. The last screen summarizes every move and suspension; +`Apply display plan` is the only action that calls the topology command. Thus +an unplug event never grabs attention or moves a task until you deliberately +open the palette and confirm the plan. + +The map shows a breadcrumb instead of a search input. Backspace moves up one +level; PageUp/PageDown reveal additional keys if a large custom tree or narrow +Head requires pages. The panel sizes itself to the current entries and follows +the configured font and bar colors. The first level is deliberately small: + +| Key | Menu | +| --- | --- | +| a | Activity (`a n` creates a named Activity; `a o` searches) | +| v | View (`v s` saves; `v u` updates; `v o` searches) | +| x | Viewset (`x s` saves current Heads; `x o` searches) | +| l | Layout (master/stack, monocle, cycle) | +| w | Window (focus, float, close) | +| h | Head (select, send a client, or `h t` reconcile changed displays) | +| r | Launch (terminal, browser, explicit shell command) | +| q | System (`q q` requests a graceful quit) | +| u | User (when the config supplies commands with `:key`) | +| Space | Search all commands | + +For example, `Super-y`, `v`, `s` reaches the same new-View name prompt +without typing a search query. The key tree only calls the existing command +layer, so it carries no independent Activity, layout, or lease policy. + +When a display change is pending, `Super-y`, `h`, `t` reaches exactly +the same reconciliation flow as the direct-search candidate. + +`Super-y → a → d` opens **Delete activity...** (also available in direct search). +First move or close every window owned by the Activity, including hidden/shared +ones, and switch all Heads away from it. The picker explains either blocker. +Choose the Activity, then explicitly select **Delete Activity: name**; the +confirmation defaults to Cancel. This removes its saved Views and cached drafts, +prunes their Viewset entries, and deletes any now-empty Viewsets. No app closes +and no Head switches. There is no undo; a changed desk invalidates the confirmation +and requires reviewing it again. Deletion is saved by ordinary session persistence. + +Selecting a ready View uses the normal strict activation command. Selecting a +View whose windows are leased on another Head replaces the result list with +three explicit options: + +| Choice | Command it runs | +| --- | --- | +| Recall without busy windows | `backend-activate-view-partially` | +| Move windows here | `backend-activate-view-taking` | +| Cancel | No model transition | + +The palette includes `Update saved view...` when the current Activity has saved +checkpoints, even if the live arrangement has no source View. Choose a target +and confirm its name before replacing it; Cancel is the default choice. +`Recall view...` explicitly restores a checkpoint, including the last one used. +Named-entity pickers, lease-conflict choices, and name +prompts remain separate transitions inside the same overlay; the command map +does not force those choices into a giant tree. Returning to the map and +searching again restores the full catalog, not the last scoped picker. + +## What the adapter does + +`start-backend` creates one Head for each configured rectangle and an +initial `inbox` Activity/View for each, claims the root window, and adopts +already-viewable normal clients into the selected Head. Each normal +`MapRequest` then: + +1. creates a Lime client in the active Presentation's Activity if necessary; +2. adds it only to the active Presentation's live draft; +3. gives it a lease when free; and +4. resolves the Head-local layout tree into X11 work-area rectangles before mapping + the leased clients; and +5. focuses the selected Head's preferred visible client (or root if blank). + +`apply-active-presentation` is the narrow convenience boundary around a +declarative render plan and its X11 executor. `build-render-plan` produces +inspectable configure/map/unmap/raise/focus effects for every configured Head; +`execute-render-plan` flushes them as one CLX batch and refuses a stale world +revision. `DestroyNotify` lifecycle handling retires a permanently gone client +from the model before the remaining geometry is reapplied. See +[the architecture document](architecture.md) for the module contracts. + +## Intentional omissions + +This initial bridge is purposefully not a complete ICCCM/EWMH-compliant +daily-driver. +It currently has no per-client decorations, theme system, custom/dynamic +key-path palettes, focus-follows-pointer policy, aspect-ratio hints, general +floating rules or stacking controls, session persistence, or complete +View/Viewset editing UI. It implements a small ICCCM slice: basic client facts, +`WM_DELETE_WINDOW`, InputHint/`WM_TAKE_FOCUS`, transient-dialog placement, +min/max/base/increment normal hints, and synthetic ConfigureNotify for managed +ConfigureRequests. Its small EWMH slice advertises `_NET_SUPPORTED`, handles +fullscreen/activate/close requests, identifies itself, publishes client and +stacking lists, and maintains `_NET_ACTIVE_WINDOW`; it does not provide fake +`_NET_WM_DESKTOP` state, external dock work areas, or the many other EWMH +states expected of a mature desktop WM. + +Those are separate layers. The value of this adapter is that the core model +can now be observed controlling real windows while those layers are added +without smuggling policy into lease resolution. diff --git a/lime.asd b/lime.asd new file mode 100644 index 0000000..f7fbdfb --- /dev/null +++ b/lime.asd @@ -0,0 +1,139 @@ +(asdf:defsystem "lime" + :description "A task-oriented X11 window manager, beginning with its pure scene model." + :author "" + :license "" + :serial t + :components ((:file "src/package") + (:file "src/conditions") + (:file "src/model") + (:file "src/layout") + (:file "src/operations") + (:file "src/membership") + (:file "src/viewset") + (:file "src/topology") + (:file "src/presentation-navigation") + (:file "src/layout-operations") + (:file "src/floating-operations")) + :in-order-to ((asdf:test-op (asdf:test-op "lime/test")))) + +(asdf:defsystem "lime/ui" + :description "Renderer-neutral command palette state for Lime frontends." + :depends-on ("lime") + :serial t + :components ((:file "src/ui/package") + (:file "src/ui/session")) + :in-order-to ((asdf:test-op (asdf:test-op "lime/ui/test")))) + +(asdf:defsystem "lime/ui/test" + :description "Tests for Lime's renderer-neutral palette session." + :depends-on ("lime/ui" "fiveam") + :serial t + :components ((:file "test/ui-package") + (:file "test/ui")) + :perform (asdf:test-op (operation component) + (declare (ignore operation component)) + (uiop:symbol-call :lime.ui.test :run-tests))) + +(asdf:defsystem "lime/persistence" + :description "Versioned model snapshots and atomic private session storage." + :depends-on ("lime" "cffi" "babel") + :serial t + :components ((:file "src/persistence/package") + (:file "src/persistence/model") + (:file "src/persistence/store")) + :in-order-to ((asdf:test-op (asdf:test-op "lime/persistence/test")))) + +(asdf:defsystem "lime/persistence/test" + :depends-on ("lime/persistence" "fiveam") + :serial t + :components ((:file "test/persistence")) + :perform (asdf:test-op (operation component) + (declare (ignore operation component)) + (uiop:symbol-call :lime.persistence.test :run-tests))) + +(asdf:defsystem "lime/x11" + :description "The intentionally small CLX/X11 bridge for Lime." + :depends-on ("lime/ui" "lime/persistence" "clx" "babel" "cffi" "bordeaux-threads" (:version "usocket" "0.8.8")) + :serial t + :components ((:file "src/x11/package") + (:file "src/x11/config-package") + (:file "src/x11/backend") + (:file "src/x11/randr") + (:file "src/x11/icccm") + (:file "src/x11/geometry") + (:file "src/x11/appearance") + (:file "src/x11/placement-policy") + (:file "src/x11/ewmh") + (:file "src/x11/attention") + (:file "src/x11/text-native") + (:file "src/x11/text") + (:file "src/x11/bar") + (:file "src/x11/status") + (:file "src/x11/status-format") + (:file "src/x11/status-desktop") + (:file "src/x11/render") + (:file "src/x11/commands") + (:file "src/x11/navigation") + (:file "src/x11/activity-navigation") + (:file "src/x11/launcher") + (:file "src/x11/pointer") + (:file "src/x11/cursor") + (:file "src/x11/session-settings") + (:file "src/x11/lifecycle") + (:file "src/x11/input") + (:file "src/x11/default-bindings") + (:file "src/x11/config") + (:file "src/x11/ui-render") + (:file "src/x11/ui") + (:file "src/x11/activity-navigation-ui") + (:file "src/x11/resilience") + (:file "src/x11/persistence")) + :in-order-to ((asdf:test-op (asdf:test-op "lime/x11/test")))) + +(asdf:defsystem "lime/x11/test" + :description "Tests for Lime's X11 adapter policy helpers." + :depends-on ("lime/x11" "fiveam") + :serial t + :components ((:file "test/x11-package") + (:file "test/x11") + (:file "test/x11-navigation") + (:file "test/x11-membership") + (:file "test/x11-activity-navigation") + (:file "test/x11-attention") + (:file "test/x11-text") + (:file "test/x11-cursor") + (:file "test/x11-session-settings") + (:file "test/x11-status")) + :perform (asdf:test-op (operation component) + (declare (ignore operation component)) + (uiop:symbol-call :lime.x11.test :run-tests))) + +(asdf:defsystem "lime/dev" + :description "A serialized Slynk/REPL development runtime for a live Lime session." + :depends-on ("lime/x11" "bordeaux-threads" "slynk") + :serial t + :components ((:file "src/x11/development-package") + (:file "src/x11/development")) + :in-order-to ((asdf:test-op (asdf:test-op "lime/dev/test")))) + +(asdf:defsystem "lime/dev/test" + :description "Tests for Lime's live developer-runtime policy." + :depends-on ("lime/dev" "fiveam") + :serial t + :components ((:file "test/development-package") + (:file "test/development")) + :perform (asdf:test-op (operation component) + (declare (ignore operation component)) + (uiop:symbol-call :lime.dev.test :run-tests))) + +(asdf:defsystem "lime/test" + :description "Tests for Lime's pure model." + :depends-on ("lime" "fiveam") + :serial t + :components ((:file "test/package") + (:file "test/model") + (:file "test/presentation-navigation") + (:file "test/membership")) + :perform (asdf:test-op (operation component) + (declare (ignore operation component)) + (uiop:symbol-call :lime.test :run-tests))) diff --git a/scripts/run-xephyr-dev b/scripts/run-xephyr-dev new file mode 100755 index 0000000..cdaa25d --- /dev/null +++ b/scripts/run-xephyr-dev @@ -0,0 +1,191 @@ +#!/usr/bin/env bash +# Start a disposable nested X11 server plus Lime's safe live-development +# runtime. Run this from the normal graphical session, never from inside the +# Xephyr session it creates. +# +# Usage: +# run-xephyr-dev [--config PATH | --no-config] [--display :99] +# [--screen 1600x1000] [--repl-port 4005] + +set -euo pipefail + +script_dir="$(cd -- "$(dirname -- "${BASH_SOURCE[0]}")" && pwd)" +repo_dir="$(cd -- "$script_dir/.." && pwd)" +config_home="${XDG_CONFIG_HOME:-${HOME}/.config}" +default_config_file="$config_home/lime/config.lisp" +display_name=":99" +screen_size="1600x1000" +repl_port="4005" +config_file="" +session_mode="default" +session_file="" + +if [[ -f "$default_config_file" ]]; then + config_file="$default_config_file" +fi + +usage() { + cat <&2; exit 2; } + config_file="$2" + shift 2 + ;; + --no-config) + config_file="" + shift + ;; + --session-file) + [[ $# -ge 2 ]] || { printf '%s needs a path.\n' "$1" >&2; exit 2; } + session_mode="file" + session_file="$2" + [[ "$session_file" = /* ]] || session_file="$PWD/$session_file" + shift 2 + ;; + --no-session) + session_mode="disabled" + shift + ;; + -d|--display) + [[ $# -ge 2 ]] || { printf '%s needs a display name.\n' "$1" >&2; exit 2; } + display_name="$2" + shift 2 + ;; + -s|--screen) + [[ $# -ge 2 ]] || { printf '%s needs a size.\n' "$1" >&2; exit 2; } + screen_size="$2" + shift 2 + ;; + -p|--repl-port) + [[ $# -ge 2 ]] || { printf '%s needs a port number.\n' "$1" >&2; exit 2; } + repl_port="$2" + shift 2 + ;; + -h|--help) + usage + exit 0 + ;; + *) + printf 'Unknown option: %s\n\n' "$1" >&2 + usage >&2 + exit 2 + ;; + esac +done + +if ! [[ "$display_name" =~ ^:[0-9]+$ ]]; then + printf '%s\n' "--display must look like :99, got $display_name" >&2 + exit 2 +fi + +display_number="${display_name#:}" +socket_path="/tmp/.X11-unix/X${display_number}" +if [[ -S "$socket_path" ]]; then + printf 'Display %s is already in use (%s). Choose another with --display.\n' \ + "$display_name" "$socket_path" >&2 + exit 2 +fi + +if ! [[ "$repl_port" =~ ^[1-9][0-9]*$ ]] || ((repl_port > 65535)); then + printf 'Slynk port must be an integer from 1 through 65535, got %s\n' "$repl_port" >&2 + exit 2 +fi + +if [[ -n "$config_file" ]]; then + if [[ ! -f "$config_file" ]]; then + printf 'Lime config does not exist: %s\n' "$config_file" >&2 + exit 2 + fi + # Resolve before changing into the repository so an explicit relative path + # still means the path relative to the shell that launched this runner. + config_file="$(cd -- "$(dirname -- "$config_file")" && pwd)/$(basename -- "$config_file")" +fi + +command -v Xephyr >/dev/null || { + printf 'Xephyr is required but was not found in PATH.\n' >&2 + exit 127 +} +command -v sbcl >/dev/null || { + printf 'SBCL is required but was not found in PATH.\n' >&2 + exit 127 +} + +cleanup() { + if kill -0 "$xephyr_pid" 2>/dev/null; then + kill -TERM "$xephyr_pid" 2>/dev/null || true + wait "$xephyr_pid" 2>/dev/null || true + fi +} + +Xephyr "$display_name" -ac -screen "$screen_size" -br -nolisten tcp & +xephyr_pid=$! +trap cleanup EXIT INT TERM + +for attempt in {1..50}; do + if [[ -S "$socket_path" ]]; then + break + fi + if ! kill -0 "$xephyr_pid" 2>/dev/null; then + wait "$xephyr_pid" + fi + sleep 0.1 +done + +if [[ ! -S "$socket_path" ]]; then + printf 'Xephyr did not make display %s ready.\n' "$display_name" >&2 + exit 1 +fi + +# DISPLAY is exported only to this script and its children. Your normal dwm +# terminal/session keeps its original display and its existing applications. +export DISPLAY="$display_name" +export LIME_XEPHYR_INTERNAL_CONFIG_FILE="$config_file" +export LIME_XEPHYR_INTERNAL_REPL_PORT="$repl_port" +export LIME_XEPHYR_INTERNAL_SESSION_MODE="$session_mode" +export LIME_XEPHYR_INTERNAL_SESSION_FILE="$session_file" + +printf 'Lime test session: Xephyr %s (%s), Slynk 127.0.0.1:%s\n' \ + "$display_name" "$screen_size" "$repl_port" +if [[ -n "$config_file" ]]; then + printf 'Configuration: %s\n' "$config_file" +else + printf 'Configuration: starter bindings (no config file)\n' +fi +printf 'Close Lime or press Ctrl-C here to tear down the nested session.\n' + +cd "$repo_dir" +sbcl --noinform --non-interactive \ + --eval '(require :asdf)' \ + --eval '(asdf:load-asd (merge-pathnames "lime.asd" (uiop:getcwd)))' \ + --eval '(asdf:load-system "lime/dev")' \ + --eval '(lime.dev:run-development-session + :display-name (uiop:getenv "DISPLAY") + :session-file (let ((mode (uiop:getenv "LIME_XEPHYR_INTERNAL_SESSION_MODE"))) + (cond ((string= mode "disabled") nil) + ((string= mode "file") (uiop:getenv "LIME_XEPHYR_INTERNAL_SESSION_FILE")) + (t :default))) + :config-file (let ((path (uiop:getenv "LIME_XEPHYR_INTERNAL_CONFIG_FILE"))) + (and (plusp (length path)) path)) + :repl-port (parse-integer (uiop:getenv "LIME_XEPHYR_INTERNAL_REPL_PORT")))' diff --git a/src/conditions.lisp b/src/conditions.lisp new file mode 100644 index 0000000..92182b7 --- /dev/null +++ b/src/conditions.lisp @@ -0,0 +1,46 @@ +(in-package #:lime.core) + +(define-condition lime-error (error) + ()) + +(define-condition unknown-entity (lime-error) + ((kind :initarg :kind :reader unknown-entity-kind) + (id :initarg :id :reader unknown-entity-id)) + (:report (lambda (condition stream) + (format stream "Unknown ~A: ~S" + (unknown-entity-kind condition) + (unknown-entity-id condition))))) + +(define-condition invalid-activity-membership (lime-error) + ((client-id :initarg :client-id :reader invalid-activity-membership-client-id) + (activity-id :initarg :activity-id + :reader invalid-activity-membership-activity-id)) + (:report (lambda (condition stream) + (format stream "Client ~S does not belong to activity ~S." + (invalid-activity-membership-client-id condition) + (invalid-activity-membership-activity-id condition))))) + +(define-condition activation-blocked (lime-error) + ((report :initarg :report :reader activation-blocked-report)) + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "The requested view activation has unresolved conflicts.")))) + +(define-condition stale-transition-plan (lime-error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "The transition plan was built against an older world state.")))) + +(define-condition degraded-presentation-update (lime-error) + ((presentation-id :initarg :presentation-id)) + (:report (lambda (condition stream) + (format stream + "Presentation ~S has unavailable windows and cannot safely update a view." + (slot-value condition 'presentation-id))))) + +(define-condition invalid-transition (lime-error) + ((description :initarg :description :reader invalid-transition-description)) + (:report (lambda (condition stream) + (format stream "Invalid Lime transition: ~A" + (invalid-transition-description condition))))) diff --git a/src/floating-operations.lisp b/src/floating-operations.lisp new file mode 100644 index 0000000..8b1ca04 --- /dev/null +++ b/src/floating-operations.lisp @@ -0,0 +1,102 @@ +(in-package #:lime.core) + +;;;; Head-local floating placement commands +;;; +;;; Floating remains ordinary Presentation placement state: it has no special +;;; lease semantics and is saved into a View only through the same explicit +;;; checkpoint commands as tiling. This file only changes the placement kind +;;; and its normalized Head-relative rectangle. + +(defun presentation-client-floating-p (presentation client-id) + "Return true when CLIENT-ID has a floating placement in PRESENTATION." + (let ((placement (%placement-for-client (presentation-placements presentation) + client-id))) + (and placement (eq (placement-kind placement) :float)))) + +(defun %require-placement (presentation client-id) + (or (%placement-for-client (presentation-placements presentation) client-id) + (error 'invalid-transition + :description "The client has no placement in this presentation."))) + +(defun %require-floating-placement (presentation client-id) + (let ((placement (%require-placement presentation client-id))) + (unless (eq (placement-kind placement) :float) + (error 'invalid-transition + :description "The command requires a floating client in this presentation.")) + placement)) + +(defun %refresh-layout-after-placement-kind-change (presentation client-id) + "Keep PRESENTATION's tiled tree consistent after CLIENT-ID changes kind." + (setf (presentation-layout-root presentation) + (if (eq (presentation-layout-mode presentation) :master-stack) + (layout-root-for-mode :master-stack + (presentation-layout-options presentation) + (presentation-placements presentation)) + (if (presentation-client-floating-p presentation client-id) + (%remove-client-from-layout (presentation-layout-root presentation) + client-id) + (%insert-tiled-client-into-layout presentation client-id)))) + presentation) + +(defun toggle-client-floating (world presentation-id client-id &key data) + "Toggle CLIENT-ID between tiled and floating in an active Presentation. + +When becoming a float, DATA is a complete or partial normalized rectangle +plist. Omitting it uses `DEFAULT-FLOATING-PLACEMENT-DATA`. When returning to +tiling, the current layout policy supplies the client's new tiling slot. +Neither transition changes leases or focus." + (let* ((presentation (%require-active-presentation world presentation-id)) + (placement (%require-placement presentation client-id)) + (weight (placement-tile-weight placement))) + (cond + ((eq (placement-kind placement) :tile) + (let ((float-data (%canonical-floating-placement-data data))) + (setf (placement-kind placement) :float + (placement-data placement) (%data-with-tile-weight float-data weight)))) + ((eq (placement-kind placement) :float) + (when data + (error 'invalid-transition + :description "Floating geometry is only accepted when converting a tiled client.")) + (setf (placement-kind placement) :tile + (placement-data placement) (%data-with-tile-weight nil weight))) + (t + (error 'invalid-transition :description "Unknown placement kind."))) + (%refresh-layout-after-placement-kind-change presentation client-id) + (setf (presentation-dirty-p presentation) t) + (%touch world) + presentation)) + +(defun toggle-focused-client-floating (world presentation-id &key data) + "Toggle the focused client between tiled and floating in PRESENTATION-ID." + (let* ((presentation (%require-active-presentation world presentation-id)) + (client-id (presentation-focus-client-id presentation))) + (unless client-id + (error 'invalid-transition + :description "The presentation has no focused client to float.")) + (toggle-client-floating world presentation-id client-id :data data))) + +(defun set-client-floating-geometry + (world presentation-id client-id + &key (x nil x-supplied-p) (y nil y-supplied-p) + (width nil width-supplied-p) (height nil height-supplied-p)) + "Update a floating client's normalized Head-relative rectangle. + +Only supplied coordinates replace the current rectangle. The resulting +rectangle must remain wholly inside the Head's normalized 0..1 space." + (unless (or x-supplied-p y-supplied-p width-supplied-p height-supplied-p) + (error 'invalid-transition + :description "Floating geometry needs at least one supplied field.")) + (let* ((presentation (%require-active-presentation world presentation-id)) + (placement (%require-floating-placement presentation client-id)) + (current (placement-data placement)) + (data (%canonical-floating-placement-data + (list :x (if x-supplied-p x (getf current :x)) + :y (if y-supplied-p y (getf current :y)) + :width (if width-supplied-p width (getf current :width)) + :height (if height-supplied-p height + (getf current :height)))))) + (setf (placement-data placement) + (%data-with-tile-weight data (placement-tile-weight placement)) + (presentation-dirty-p presentation) t) + (%touch world) + presentation)) diff --git a/src/layout-operations.lisp b/src/layout-operations.lisp new file mode 100644 index 0000000..27ebca3 --- /dev/null +++ b/src/layout-operations.lisp @@ -0,0 +1,304 @@ +(in-package #:lime.core) + +;;;; Head-local layout commands +;;; +;;; These commands mutate only an active Presentation. They deliberately do +;;; not know about CLX, keys, mouse drags, or saved View updates: frontends +;;; render the result, and a View changes only through an explicit checkpoint +;;; command. + +(defun %require-active-presentation (world presentation-id) + (let ((presentation (find-presentation world presentation-id))) + (unless (presentation-active-p world presentation) + (error 'invalid-transition + :description "Only an active presentation can change its layout.")) + presentation)) + +(defun %canonical-master-stack-options (options) + (multiple-value-bind (master-count master-ratio orientation) + (%master-stack-options options) + (list :master-count master-count + :master-ratio master-ratio + :orientation orientation))) + +(defun %active-layout-root (presentation) + "Return the actual tiled tree used by PRESENTATION before a manual edit." + (let ((placements (presentation-placements presentation))) + (case (presentation-layout-mode presentation) + (:master-stack + (layout-root-for-mode :master-stack + (presentation-layout-options presentation) + placements)) + (otherwise + (or (presentation-layout-root presentation) + (default-layout-root (%tiled-client-ids placements))))))) + +(defun set-presentation-layout-mode (world presentation-id layout-mode + &key layout-options) + "Apply one built-in LAYOUT-MODE to an active Presentation. + +`:MANUAL` preserves the current explicit tree. `:MASTER-STACK` owns a +canonical tree generated from tile placement order and its option plist. +`:MONOCLE` preserves the tree but renders only the focused tiled client." + (let ((presentation (%require-active-presentation world presentation-id))) + (%validate-layout-mode layout-mode layout-options) + (let ((options + (case layout-mode + (:master-stack (%canonical-master-stack-options layout-options)) + (otherwise + (when layout-options + (error 'invalid-transition + :description "Only :MASTER-STACK accepts layout options.")) + nil)))) + (setf (presentation-layout-root presentation) + (case layout-mode + (:master-stack + (layout-root-for-mode :master-stack options + (presentation-placements presentation))) + (otherwise + (%active-layout-root presentation))) + (presentation-layout-mode presentation) layout-mode + (presentation-layout-options presentation) options + (presentation-dirty-p presentation) t) + (%touch world) + presentation))) + +(defun set-presentation-master-stack-layout + (world presentation-id &key (master-count 1) (master-ratio 3/5) + (orientation :horizontal)) + "Use master/stack on PRESENTATION-ID, with the existing tile order. + +The first MASTER-COUNT tiled clients form the master area. New tiled windows +retain this policy rather than silently reverting to the manual fallback." + (set-presentation-layout-mode + world presentation-id :master-stack + :layout-options (list :master-count master-count + :master-ratio master-ratio + :orientation orientation))) + +(defun set-presentation-monocle-layout (world presentation-id) + "Use monocle on PRESENTATION-ID, showing its focused tiled client only." + (set-presentation-layout-mode world presentation-id :monocle)) + +(defun set-presentation-manual-layout (world presentation-id) + "Return PRESENTATION-ID to its current explicit binary layout tree." + (set-presentation-layout-mode world presentation-id :manual)) + +(defun %require-tiled-placement (presentation client-id) + (let ((placement (%placement-for-client (presentation-placements presentation) + client-id))) + (unless (and placement (eq (placement-kind placement) :tile)) + (error 'invalid-transition + :description "The layout command requires a tiled client in this presentation.")) + placement)) + +(defun %layout-contains-client-p (layout-root client-id) + (member client-id (layout-node-client-ids layout-root) :test #'equal)) + +(defun set-client-tile-weight (world presentation-id client-id weight) + "Set CLIENT-ID's relative size within its master/stack column. + +Only this active draft changes. The column's other tiles share the remaining +space proportionally; the master/stack divide, focus, order and leases stay +intact. A sole tile still fills its column, retaining the weight for later." + (%validate-tile-weight weight) + (let* ((presentation (%require-active-presentation world presentation-id)) + (placement (%require-tiled-placement presentation client-id))) + (unless (eq (presentation-layout-mode presentation) :master-stack) + (error 'invalid-transition + :description "Tile weight adjustment requires the master-stack layout.")) + (unless (= weight (placement-tile-weight placement)) + (setf (placement-data placement) + (%data-with-tile-weight (placement-data placement) weight) + (presentation-layout-root presentation) + (layout-root-for-mode :master-stack + (presentation-layout-options presentation) + (presentation-placements presentation)) + (presentation-dirty-p presentation) t) + (%touch world)) + presentation)) + +(defun %map-layout-leaves (layout-root function) + (typecase layout-root + (null nil) + (layout-leaf + (make-layout-leaf :client-id (funcall function + (layout-leaf-client-id layout-root)))) + (layout-split + (make-layout-split :orientation (layout-split-orientation layout-root) + :ratio (layout-split-ratio layout-root) + :first (%map-layout-leaves (layout-split-first layout-root) + function) + :second (%map-layout-leaves (layout-split-second layout-root) + function))))) + +(defun %edit-direct-parent-split (layout-root client-id transform) + "Edit CLIENT-ID's nearest containing split and return ROOT, EDITED-P." + (typecase layout-root + (layout-leaf (values layout-root nil)) + (layout-split + (let ((first (layout-split-first layout-root)) + (second (layout-split-second layout-root))) + (cond + ((or (and (typep first 'layout-leaf) + (equal (layout-leaf-client-id first) client-id)) + (and (typep second 'layout-leaf) + (equal (layout-leaf-client-id second) client-id))) + (values (funcall transform layout-root) t)) + ((%layout-contains-client-p first client-id) + (multiple-value-bind (new-first edited-p) + (%edit-direct-parent-split first client-id transform) + (values (make-layout-split :orientation (layout-split-orientation layout-root) + :ratio (layout-split-ratio layout-root) + :first new-first :second second) + edited-p))) + ((%layout-contains-client-p second client-id) + (multiple-value-bind (new-second edited-p) + (%edit-direct-parent-split second client-id transform) + (values (make-layout-split :orientation (layout-split-orientation layout-root) + :ratio (layout-split-ratio layout-root) + :first first :second new-second) + edited-p))) + (t (values layout-root nil))))))) + +(defun %commit-manual-layout (world presentation layout-root) + ;; SET-PRESENTATION-LAYOUT-ROOT validates exact placement coverage, marks the + ;; draft dirty, and makes switching away from a built-in policy explicit. + (set-presentation-layout-root world (presentation-id presentation) layout-root)) + +(defun set-focused-layout-split-orientation (world presentation-id orientation) + "Set the nearest split around the focused tiled client to ORIENTATION." + (unless (member orientation '(:horizontal :vertical)) + (error 'invalid-transition + :description "A split orientation must be :HORIZONTAL or :VERTICAL.")) + (let* ((presentation (%require-active-presentation world presentation-id)) + (client-id (presentation-focus-client-id presentation))) + (unless client-id + (error 'invalid-transition :description "The presentation has no focused client.")) + (%require-tiled-placement presentation client-id) + (multiple-value-bind (layout-root edited-p) + (%edit-direct-parent-split + (%active-layout-root presentation) client-id + (lambda (split) + (make-layout-split :orientation orientation + :ratio (layout-split-ratio split) + :first (layout-split-first split) + :second (layout-split-second split)))) + (unless edited-p + (error 'invalid-transition + :description "A one-client layout has no split to orient.")) + (%commit-manual-layout world presentation layout-root)))) + +(defun adjust-focused-layout-split-ratio (world presentation-id delta) + "Add DELTA to the nearest split around the focused tiled client. + +The result is clamped to 1/20 through 19/20 to retain usable space for both +children while still allowing an intentionally dominant master area." + (unless (and (realp delta) (not (zerop delta))) + (error 'invalid-transition + :description "A split ratio adjustment must be a non-zero real number.")) + (let* ((presentation (%require-active-presentation world presentation-id)) + (client-id (presentation-focus-client-id presentation))) + (unless client-id + (error 'invalid-transition :description "The presentation has no focused client.")) + (%require-tiled-placement presentation client-id) + (multiple-value-bind (layout-root edited-p) + (%edit-direct-parent-split + (%active-layout-root presentation) client-id + (lambda (split) + (make-layout-split + :orientation (layout-split-orientation split) + :ratio (max 1/20 (min 19/20 (+ (layout-split-ratio split) delta))) + :first (layout-split-first split) + :second (layout-split-second split)))) + (unless edited-p + (error 'invalid-transition + :description "A one-client layout has no split to resize.")) + (%commit-manual-layout world presentation layout-root)))) + +(defun swap-presentation-layout-clients (world presentation-id first-client-id + second-client-id) + "Swap two tiled clients' slots, retaining master/stack policy when active." + (let ((presentation (%require-active-presentation world presentation-id))) + (%require-tiled-placement presentation first-client-id) + (%require-tiled-placement presentation second-client-id) + (when (eq (presentation-layout-mode presentation) :master-stack) + ;; Move the placements themselves: each window keeps its own weight. + ;; Editing only the generated tree would leave master/stack for manual + ;; mode and prevent subsequent column-share adjustments. + (let ((first (%placement-for-client (presentation-placements presentation) + first-client-id)) + (second (%placement-for-client (presentation-placements presentation) + second-client-id))) + (setf (presentation-placements presentation) + (mapcar (lambda (placement) + (cond ((eq placement first) second) + ((eq placement second) first) + (t placement))) + (presentation-placements presentation)) + (presentation-layout-root presentation) + (layout-root-for-mode :master-stack + (presentation-layout-options presentation) + (presentation-placements presentation)) + (presentation-dirty-p presentation) t) + (%touch world) + (return-from swap-presentation-layout-clients presentation))) + (let ((layout-root (%active-layout-root presentation))) + (%commit-manual-layout + world presentation + (%map-layout-leaves + layout-root + (lambda (client-id) + (cond ((equal client-id first-client-id) second-client-id) + ((equal client-id second-client-id) first-client-id) + (t client-id)))))))) + +(defun swap-focused-layout-client (world presentation-id &key (direction :next)) + "Swap the focused client with the next or previous visible tiled client." + (unless (member direction '(:next :previous)) + (error 'invalid-transition + :description "Layout swap direction must be :NEXT or :PREVIOUS.")) + (let* ((presentation (%require-active-presentation world presentation-id)) + (focus-client-id (presentation-focus-client-id presentation))) + (unless focus-client-id + (error 'invalid-transition :description "The presentation has no focused client.")) + (%require-tiled-placement presentation focus-client-id) + (let* ((layout-client-ids (layout-node-client-ids + (%active-layout-root presentation))) + (visible-client-ids + (remove-if-not + (lambda (client-id) + (let ((lease (lease-for-client world client-id))) + (and lease + (equal (lease-presentation-id lease) + (presentation-id presentation))))) + layout-client-ids))) + (when (< (length visible-client-ids) 2) + (error 'invalid-transition + :description "Layout swap requires two visible tiled clients.")) + (let* ((ordered (if (eq direction :previous) + (reverse visible-client-ids) + visible-client-ids)) + (suffix (member focus-client-id ordered :test #'equal)) + (other-client-id (or (second suffix) (first ordered)))) + (swap-presentation-layout-clients world presentation-id focus-client-id + other-client-id))))) + +(defun promote-client-to-master (world presentation-id client-id) + "Make CLIENT-ID the first master/stack client in PRESENTATION-ID. + +Promoting is explicit: it switches the live draft to master/stack, preserves +existing master/stack options when present, and never alters a saved View." + (let ((presentation (%require-active-presentation world presentation-id))) + (%require-tiled-placement presentation client-id) + (let* ((placement (%placement-for-client (presentation-placements presentation) + client-id)) + (options (if (eq (presentation-layout-mode presentation) :master-stack) + (presentation-layout-options presentation) + nil))) + (setf (presentation-placements presentation) + (cons placement + (remove client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal))) + (set-presentation-layout-mode world presentation-id :master-stack + :layout-options options)))) diff --git a/src/layout.lisp b/src/layout.lisp new file mode 100644 index 0000000..69f9954 --- /dev/null +++ b/src/layout.lisp @@ -0,0 +1,209 @@ +(in-package #:lime.core) + +;;;; Head-local layout resolution + +(defstruct geometry + "An integer rectangle in a Head's usable coordinate space." + x + y + width + height) + +(defun default-layout-root (client-ids) + "Build Lime's deliberately boring fallback tree. + +It is used when a View has tiled placements but no explicit tree yet, and when +a newly opened tiled client is added to a draft. Higher-level layout policy +can replace this without changing the lease model." + (reduce (lambda (tree client-id) + (make-layout-split :orientation :horizontal + :ratio 1/2 + :first tree + :second (make-layout-leaf :client-id client-id))) + (rest client-ids) + :initial-value (and client-ids + (make-layout-leaf :client-id (first client-ids))))) + +(defun %linear-layout-root (client-ids orientation weights) + "Build proportional slices for CLIENT-IDS in their existing order." + (labels ((build (remaining remaining-weights total) + (cond + ((null remaining) nil) + ((null (rest remaining)) + (make-layout-leaf :client-id (first remaining))) + (t + (make-layout-split + :orientation orientation + :ratio (/ (first remaining-weights) total) + :first (make-layout-leaf :client-id (first remaining)) + :second (build (rest remaining) (rest remaining-weights) + (- total (first remaining-weights)))))))) + (build client-ids weights (reduce #'+ weights :initial-value 0)))) + +(defun %master-stack-options (options) + "Return validated master/stack parameters from a layout option plist." + (let ((master-count (getf options :master-count 1)) + (master-ratio (getf options :master-ratio 3/5)) + (orientation (getf options :orientation :horizontal))) + (unless (and (integerp master-count) (plusp master-count)) + (error 'invalid-transition + :description "Master/stack :MASTER-COUNT must be a positive integer.")) + (unless (and (realp master-ratio) (< 0 master-ratio 1)) + (error 'invalid-transition + :description "Master/stack :MASTER-RATIO must be strictly between zero and one.")) + (unless (member orientation '(:horizontal :vertical)) + (error 'invalid-transition + :description "Master/stack :ORIENTATION must be :HORIZONTAL or :VERTICAL.")) + (values master-count master-ratio orientation))) + +(defun master-stack-layout-root (client-ids + &key (master-count 1) + (master-ratio 3/5) + (orientation :horizontal) weights) + "Build a conventional master/stack tree for CLIENT-IDS. + +The first MASTER-COUNT clients form the master area; the remaining clients +share the stack. WEIGHTS, when supplied, is a list of positive relative sizes +in CLIENT-IDS order; otherwise all sizes are equal. Each column normalizes its +weights independently. ORIENTATION controls the master/stack divide, while +the two areas subdivide across the other axis. No geometry is resolved here." + (%master-stack-options (list :master-count master-count + :master-ratio master-ratio + :orientation orientation)) + (unless (or (null weights) + (and (listp weights) (= (length weights) (length client-ids)))) + (error 'invalid-transition + :description "Master/stack needs one weight per tiled client.")) + (setf weights (or weights (make-list (length client-ids) :initial-element 1))) + (mapc #'%validate-tile-weight weights) + (let* ((effective-master-count (min master-count (length client-ids))) + (masters (subseq client-ids 0 effective-master-count)) + (stack (nthcdr effective-master-count client-ids)) + (cross-orientation (ecase orientation + (:horizontal :vertical) + (:vertical :horizontal))) + (master-root (%linear-layout-root masters cross-orientation + (subseq weights 0 effective-master-count))) + (stack-root (%linear-layout-root stack cross-orientation + (nthcdr effective-master-count weights)))) + (cond + ((null master-root) nil) + ((null stack-root) master-root) + (t + (make-layout-split :orientation orientation + :ratio master-ratio + :first master-root + :second stack-root))))) + +(defun layout-root-for-mode (layout-mode layout-options placements) + "Build the canonical tree required by LAYOUT-MODE for PLACEMENTS. + +Manual and monocle presentations retain their explicit tree; callers use this +function when a built-in mode needs to refresh its stored checkpoint tree." + (let ((client-ids (%tiled-client-ids placements))) + (ecase layout-mode + (:master-stack + (multiple-value-bind (master-count master-ratio orientation) + (%master-stack-options layout-options) + (master-stack-layout-root client-ids + :master-count master-count + :master-ratio master-ratio + :orientation orientation + :weights (loop for placement in placements + when (eq (placement-kind placement) :tile) + collect (placement-tile-weight placement))))) + ((:manual :monocle) + (default-layout-root client-ids))))) + +(defun %bounded-split-size (extent ratio) + "Return a positive size for the first child of a split. + +For a pathological one-pixel Head, both children intentionally receive a +one-pixel rectangle. The X11 adapter normally works with much larger work +areas; preserving positive dimensions here keeps the function total." + (if (> extent 1) + (max 1 (min (1- extent) (round (* extent ratio)))) + 1)) + +(defun %resolve-layout-node (layout-root x y width height) + (typecase layout-root + (null '()) + (layout-leaf + (list (cons (layout-leaf-client-id layout-root) + (make-geometry :x x :y y :width width :height height)))) + (layout-split + (ecase (layout-split-orientation layout-root) + (:horizontal + (let* ((first-width (%bounded-split-size width + (layout-split-ratio layout-root))) + (second-width (max 1 (- width first-width)))) + (append (%resolve-layout-node (layout-split-first layout-root) + x y first-width height) + (%resolve-layout-node (layout-split-second layout-root) + (+ x first-width) y second-width height)))) + (:vertical + (let* ((first-height (%bounded-split-size height + (layout-split-ratio layout-root))) + (second-height (max 1 (- height first-height)))) + (append (%resolve-layout-node (layout-split-first layout-root) + x y width first-height) + (%resolve-layout-node (layout-split-second layout-root) + x (+ y first-height) width second-height)))))))) + +(defun %normalized-value (data key default) + (let ((value (and (listp data) (getf data key default)))) + (if (realp value) + (max 0 (min 1 value)) + default))) + +(defun %resolve-float-placement (placement x y width height) + (let* ((data (placement-data placement)) + (left (%normalized-value data :x 0)) + (top (%normalized-value data :y 0)) + (relative-width (%normalized-value data :width 1)) + (relative-height (%normalized-value data :height 1)) + (resolved-width (max 1 (round (* width relative-width)))) + (resolved-height (max 1 (round (* height relative-height))))) + (cons (placement-client-id placement) + (make-geometry :x (+ x (round (* width left))) + :y (+ y (round (* height top))) + :width resolved-width + :height resolved-height)))) + +(defun resolve-presentation-layout (presentation width height &key (x 0) (y 0)) + "Resolve PRESENTATION's Head-local layout into an alist of client geometry. + +The function is deliberately pure: it does not know which clients currently +hold leases, nor does it perform X11 effects. The backend filters this result +through leases before mapping clients." + (let* ((placements (presentation-placements presentation)) + (tiled-client-ids (%tiled-client-ids placements)) + (layout-root + (case (presentation-layout-mode presentation) + (:master-stack + (layout-root-for-mode :master-stack + (presentation-layout-options presentation) + placements)) + (otherwise + (or (presentation-layout-root presentation) + (default-layout-root tiled-client-ids))))) + (tiling + (if (eq (presentation-layout-mode presentation) :monocle) + (let ((client-id (if (member (presentation-focus-client-id presentation) + tiled-client-ids :test #'equal) + (presentation-focus-client-id presentation) + (first tiled-client-ids)))) + (if client-id + (list (cons client-id + (make-geometry :x x :y y + :width (max 1 width) + :height (max 1 height)))) + '())) + (%resolve-layout-node layout-root x y (max 1 width) (max 1 height)))) + (floating (loop for placement in placements + when (eq (placement-kind placement) :float) + collect (%resolve-float-placement placement + x y + (max 1 width) + (max 1 height))))) + (append tiling floating))) diff --git a/src/membership.lisp b/src/membership.lisp new file mode 100644 index 0000000..cf9a72d --- /dev/null +++ b/src/membership.lisp @@ -0,0 +1,276 @@ +(in-package #:lime.core) + +;;;; Explicit membership transitions. Plan copies first, then commit without +;;;; calling user policy or rendering midway through a lease/ownership change. + +(defun activity-deletion-summary (world activity-id) + "Describe deletion without changing anything. Owned clients and mounts block it." + (let* ((activity (find-activity world activity-id)) + (clients (copy-list (activity-client-ids activity))) + (views (copy-list (activity-view-ids activity))) + (heads (loop for head being the hash-values of (world-heads world) + for p = (current-presentation world (head-id head)) + when (and p (equal activity-id (presentation-activity-id p))) + collect (head-id head))) + (drafts (loop for p being the hash-values of (world-presentations world) + when (equal activity-id (presentation-activity-id p)) + collect (presentation-id p))) + (viewsets nil) (empty-viewsets nil) (entry-count 0)) + (dolist (viewset (list-viewsets world)) + (let ((count (count-if (lambda (entry) (member (viewset-entry-view-id entry) views :test #'equal)) + (viewset-entries viewset)))) + (when (plusp count) + (incf entry-count count) + (push (viewset-id viewset) viewsets) + (when (= count (length (viewset-entries viewset))) + (push (viewset-id viewset) empty-viewsets))))) + (list :activity-id activity-id :name (activity-name activity) + :revision (world-revision world) :ready-p (not (or clients heads)) + :client-ids clients :head-ids heads :view-ids views :presentation-ids drafts + :viewset-ids (nreverse viewsets) :empty-viewset-ids (nreverse empty-viewsets) + :viewset-entry-count entry-count))) + +(defun delete-activity (world activity-id &key expected-revision) + "Delete an unmounted Activity with no home clients, never closing any client. + +Removes its saved Views and cached/suspended drafts. References in Viewsets +are pruned, deleting a Viewset only when it would become empty. Shared guests +keep their homes and leases elsewhere. EXPECTED-REVISION protects an earlier +confirmation from state changes. No mutation occurs until all checks pass." + (when (and expected-revision (/= expected-revision (world-revision world))) + (error 'stale-transition-plan)) + (validate-world world) + (let* ((summary (activity-deletion-summary world activity-id)) + (views (getf summary :view-ids)) + (updates nil)) + (when (getf summary :client-ids) + (error 'invalid-transition + :description "Move or close all windows owned by this Activity first, including hidden/shared windows.")) + (when (getf summary :head-ids) + (error 'invalid-transition + :description "Switch every Head away from this Activity before deleting it.")) + (dolist (id (getf summary :viewset-ids)) + (let ((viewset (find-viewset world id))) + (push (cons viewset + (remove-if (lambda (entry) (member (viewset-entry-view-id entry) views :test #'equal)) + (viewset-entries viewset))) + updates))) + ;; All validation and list construction precede the commit. + (dolist (update updates) + (if (cdr update) + (setf (viewset-entries (car update)) (cdr update)) + (remhash (viewset-id (car update)) (world-viewsets world)))) + (dolist (id views) (remhash id (world-views world))) + (dolist (id (getf summary :presentation-ids)) (remhash id (world-presentations world))) + (remhash activity-id (world-activities world)) + (%touch world) + summary)) + +(defun %client-removal-updates (world client-id predicate focus-direction) + (let (updates) + (dolist (table (list (world-views world) (world-presentations world))) + (maphash + (lambda (id container) + (declare (ignore id)) + (when (and (%placement-for-client (slot-value container 'placements) client-id) + (funcall predicate container)) + (let* ((presentation-p (typep container 'presentation)) + (copy (if presentation-p (copy-presentation container) (copy-view container))) + (old-ids (%placement-client-ids (slot-value container 'placements))) + (old-focus (slot-value container 'focus-client-id)) + (direction (%focus-direction-for-container focus-direction container))) + (%remove-client-from-container copy client-id) + (when presentation-p + (setf (presentation-unavailable-client-ids copy) + (%remove-id client-id (presentation-unavailable-client-ids copy)) + (presentation-dirty-p copy) t)) + (when (equal old-focus client-id) + (setf (slot-value copy 'focus-client-id) + (%focus-replacement-after-removal + old-ids client-id + (if (and presentation-p (presentation-active-p world container)) + (remove client-id (presentation-leased-client-ids world container) :test #'equal) + (%placement-client-ids (slot-value copy 'placements))) + direction))) + (push (cons container copy) updates)))) + table)) + updates)) + +(defun %commit-container-updates (updates) + ;; Preserve object identity: the adapter and callers may retain a draft. + (dolist (update updates) + (let ((original (car update)) (copy (cdr update))) + (dolist (slot '(placements layout-root focus-client-id)) + (setf (slot-value original slot) (slot-value copy slot))) + (when (typep original 'presentation) + (setf (presentation-unavailable-client-ids original) (presentation-unavailable-client-ids copy) + (presentation-dirty-p original) (presentation-dirty-p copy)))))) + +(defun set-client-shared (world client-id shared-p &key (focus-direction :previous)) + "Make a client eligible everywhere, or private to its existing home. + +Sharing never changes placements or leases. Revoking sharing prunes foreign +Views/drafts and releases a foreign lease, without summoning the client home." + (unless (member shared-p '(nil t)) + (error 'invalid-transition :description "SHARED-P must be T or NIL.")) + (let ((client (find-client world client-id))) + (unless (eql (client-shared-p client) shared-p) + (let* ((home (client-activity-id client)) + (updates (unless shared-p + (%client-removal-updates + world client-id (lambda (c) (not (equal home (slot-value c 'activity-id)))) + focus-direction))) + (lease (lease-for-client world client-id)) + (release-p (and (not shared-p) lease + (not (equal home (presentation-activity-id + (find-presentation world (lease-presentation-id lease)))))))) + (%commit-container-updates updates) + (when release-p (remhash client-id (world-leases world))) + (setf (client-shared-p client) shared-p) + (%touch world))) + client)) + +(defun make-client-private-in-presentation + (world client-id presentation-id &key (focus-direction :previous) expected-revision) + "Make a leased window private to the Activity where it is currently used. + +Preserve the current lease and arrangement exactly. Prepare foreign View/draft +cleanup before atomically changing home membership and sharing. Unlike a move, +this never parks, reinserts, focuses, or relocates the client." + (when (and expected-revision (/= expected-revision (world-revision world))) + (error 'stale-transition-plan)) + (let* ((client (find-client world client-id)) + (presentation (find-presentation world presentation-id)) + (lease (lease-for-client world client-id)) + (old-home (find-activity world (client-activity-id client))) + (home (find-activity world (presentation-activity-id presentation)))) + (unless (and (presentation-active-p world presentation) + lease (equal presentation-id (lease-presentation-id lease)) + (member client-id (presentation-leased-client-ids world presentation) :test #'equal)) + (error 'invalid-transition :description "Make private requires the window's current active arrangement.")) + (%ensure-client-in-activity world client-id (activity-id home)) + (when (client-shared-p client) + (let ((updates (%client-removal-updates + world client-id + (lambda (container) (not (equal (activity-id home) (slot-value container 'activity-id)))) + focus-direction))) + ;; All validation and user policy ran above, on prepared copies. + (%commit-container-updates updates) + (unless (eq old-home home) + (setf (activity-client-ids old-home) (%remove-id client-id (activity-client-ids old-home)) + (activity-client-ids home) (%add-unique-id client-id (activity-client-ids home)) + (client-activity-id client) (activity-id home))) + (setf (client-shared-p client) nil) + (%touch world))) + client)) + +(defun %move-client-membership (world client-id activity-id + &key target-head-id active-target-id inactive-target-id (default-layout :master-stack) + (tiled-insertion-position :back) (focus-direction :previous)) + "Plan a membership move completely before committing containers and lease. + +The public parked-move and active-destination commands select distinct paths; +only the latter explicitly authorizes a live destination lease." + (when (> (count-if #'identity (list target-head-id active-target-id inactive-target-id)) 1) + (error 'invalid-transition :description "Choose one move destination.")) + (let* ((client (find-client world client-id)) + (old-home (find-activity world (client-activity-id client))) + (destination (find-activity world activity-id)) + (lease (lease-for-client world client-id)) + (holder (and lease (find-presentation world (lease-presentation-id lease))))) + (when target-head-id (find-head world target-head-id)) + (%validate-layout-mode default-layout nil) + (unless (%valid-tiled-insertion-position-p tiled-insertion-position) + (error 'invalid-transition :description "Tiled insertion position must be :FRONT or :BACK.")) + (let* ((target (if (or active-target-id inactive-target-id) + (find-presentation world (or active-target-id inactive-target-id)) + (and target-head-id (activity-draft-for-head world activity-id target-head-id)))) + (new-p (and target-head-id (null target))) + (prepared (when (or target-head-id active-target-id inactive-target-id) + (if target (copy-presentation target) + (make-presentation :id (format nil "presentation-~D" (1+ (world-next-presentation-number world))) + :head-id target-head-id :activity-id activity-id + :layout-mode default-layout))))) + (when (and target (not (equal activity-id (presentation-activity-id target)))) + (error 'invalid-transition :description "The move destination belongs to another Activity.")) + (if active-target-id + (unless (and (presentation-active-p world target) + (equal activity-id (presentation-activity-id target))) + (error 'invalid-transition :description "The explicit move destination must be active in its Activity.")) + (when (and target (presentation-active-p world target)) + (error 'invalid-transition :description "Move targets an inactive Activity draft; do not silently alter another active desk."))) + (when prepared + (unless (%placement-for-client (presentation-placements prepared) client-id) + (let ((placement (or (and holder (%placement-for-client (presentation-placements holder) client-id)) + (make-placement :client-id client-id)))) + (setf placement (first (%copy-placements (list placement)))) + (setf (presentation-placements prepared) + (if (and (eq (placement-kind placement) :tile) (eq tiled-insertion-position :front)) + (cons placement (presentation-placements prepared)) + (append (presentation-placements prepared) (list placement)))) + (when (eq (placement-kind placement) :tile) + (setf (presentation-layout-root prepared) + (%insert-tiled-client-into-layout prepared client-id :position tiled-insertion-position))))) + (when (eq (presentation-layout-mode prepared) :master-stack) + (setf (presentation-layout-root prepared) + (layout-root-for-mode :master-stack (presentation-layout-options prepared) + (presentation-placements prepared)))) + (setf (presentation-focus-client-id prepared) client-id + (presentation-dirty-p prepared) t + (presentation-unavailable-client-ids prepared) + (%remove-id client-id (presentation-unavailable-client-ids prepared)))) + (let ((updates (%client-removal-updates + world client-id + (if (client-shared-p client) + (lambda (c) (and (typep c 'presentation) (not (eq c target)))) + (lambda (c) (or (eq c holder) + (not (equal activity-id (slot-value c 'activity-id)))))) + focus-direction))) + ;; No validation/user callbacks beyond this point. + (%commit-container-updates updates) + (remhash client-id (world-leases world)) + (unless (eq old-home destination) + (setf (activity-client-ids old-home) (%remove-id client-id (activity-client-ids old-home)) + (activity-client-ids destination) (%add-unique-id client-id (activity-client-ids destination)) + (client-activity-id client) activity-id)) + (when prepared + (if new-p + (progn + (incf (world-next-presentation-number world)) + (setf (gethash (presentation-id prepared) (world-presentations world)) prepared)) + (%commit-container-updates (list (cons target prepared))))) + (when active-target-id + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id :presentation-id active-target-id))) + (%touch world))) + client)) + +(defun move-client-to-activity (world client-id activity-id + &key target-head-id target-presentation-id (default-layout :master-stack) + (tiled-insertion-position :back) (focus-direction :previous)) + "Rehome CLIENT-ID and park it, without switching or taking another Head. + +With TARGET-HEAD-ID, queue it in that Activity's inactive arrangement for the +Head. TARGET-PRESENTATION-ID instead queues it in that inactive arrangement, +including one suspended after unplugging a monitor. Without either, park it. +Private clients leave foreign saved +Views and drafts; shared clients retain valid saved requests and sharing." + (%move-client-membership world client-id activity-id + :target-head-id target-head-id :inactive-target-id target-presentation-id + :default-layout default-layout + :tiled-insertion-position tiled-insertion-position + :focus-direction focus-direction)) + +(defun move-client-to-presentation (world client-id presentation-id + &key (tiled-insertion-position :back) (focus-direction :previous)) + "Explicitly rehome and lease CLIENT-ID to an already active arrangement. + +Neither Head switches Activities. Private clients leave old saved Views and +live arrangements; the destination receives an unsaved placement preserving +tile/float kind and geometry. Plan all policy before mutating membership, +placements, or leases, so a rejected move cannot leave a half-moved client." + (let ((target (find-presentation world presentation-id))) + (%move-client-membership world client-id (presentation-activity-id target) + :active-target-id presentation-id + :tiled-insertion-position tiled-insertion-position + :focus-direction focus-direction))) diff --git a/src/model.lisp b/src/model.lisp new file mode 100644 index 0000000..435e73f --- /dev/null +++ b/src/model.lisp @@ -0,0 +1,698 @@ +(in-package #:lime.core) + +;;;; Core vocabulary +;;; +;;; Activity durable task container and client pool +;;; View immutable-ish, named one-Head checkpoint +;;; Head one independently addressable display rectangle +;;; Presentation mutable, Head-local realization of an activity/view +;;; Lease exclusive runtime right to map one real client in a presentation + +(defun %make-id-table () + (make-hash-table :test #'equal)) + +(defstruct (world (:constructor %make-world)) + (revision 0) + (activities (%make-id-table)) + (clients (%make-id-table)) + (views (%make-id-table)) + ;; A Viewset is a named, durable mapping of selected Heads to saved Views. + ;; It is not a current-desktop mode and never owns a lease itself. + (viewsets (%make-id-table)) + (heads (%make-id-table)) + (presentations (%make-id-table)) + ;; Client id -> lease. This makes duplicate visible clients impossible by + ;; construction. + (leases (%make-id-table)) + (next-presentation-number 0)) + +(defun make-world () + "Make an empty, protocol-independent Lime model." + (%make-world)) + +(defstruct activity + id + name + (client-ids '()) + (view-ids '())) + +(defstruct client + id + activity-id + (shared-p nil) + name + metadata) + +(defstruct placement + "A portable request to show CLIENT-ID in a View or Presentation. + +KIND is currently :TILE or :FLOAT. A floating placement's DATA is a complete +normalized, Head-relative rectangle. DATA may also retain :TILE-WEIGHT, a +positive relative share within a master/stack column (default 1), including +while floating. Tiling topology lives in LAYOUT-ROOT on a View or Presentation." + client-id + (kind :tile) + data) + +(defun %validate-tile-weight (weight) + (unless (and (realp weight) (plusp weight)) + (error 'invalid-transition + :description "A tile weight must be a positive real number.")) + weight) + +(defun placement-tile-weight (placement) + "Return PLACEMENT's relative tiled size, defaulting to one. + +The weight belongs to this draft/checkpoint placement, never to the global +client. Monocle and floating ignore it while retaining it for later tiling." + (let ((data (placement-data placement))) + (unless (and (listp data) (evenp (length data))) + (error 'invalid-transition + :description "Placement data must be a property list.")) + (%validate-tile-weight (getf data :tile-weight 1)))) + +(defun %data-with-tile-weight (data weight) + "Return independent DATA with WEIGHT, omitting the default weight of one." + (%validate-tile-weight weight) + (let ((result (copy-tree data))) + (if (= weight 1) + (remf result :tile-weight) + (setf (getf result :tile-weight) weight)) + result)) + +(defun default-floating-placement-data () + "Return Lime's initial normalized rectangle for a newly floated client." + (list :x 1/8 :y 1/8 :width 3/4 :height 3/4)) + +(defun %canonical-floating-placement-data (data) + "Validate DATA and return a complete normalized floating rectangle. + +Floating geometry is deliberately Head-relative so the pure model never needs +pixel dimensions. Rectangles remain wholly inside their owning Head for this +initial policy; a later off-screen/strut-aware layer can widen that contract." + (unless (or (null data) + (and (listp data) + (evenp (length data)) + (loop for tail on data by #'cddr + always (member (first tail) '(:x :y :width :height + :tile-weight))))) + (error 'invalid-transition + :description "Floating placement data must be a rectangle property list.")) + (let* ((defaults (default-floating-placement-data)) + (x (getf data :x (getf defaults :x))) + (y (getf data :y (getf defaults :y))) + (width (getf data :width (getf defaults :width))) + (height (getf data :height (getf defaults :height)))) + (unless (and (realp x) (realp y) (realp width) (realp height) + (<= 0 x) (< x 1) + (<= 0 y) (< y 1) + (< 0 width) (<= width 1) + (< 0 height) (<= height 1) + (<= (+ x width) 1) + (<= (+ y height) 1)) + (error 'invalid-transition + :description "A floating rectangle must be positive and fit inside its Head.")) + (%data-with-tile-weight (list :x x :y y :width width :height height) + (getf data :tile-weight 1)))) + +(defstruct layout-leaf + "A tiled client leaf in a Head-local binary layout tree." + client-id) + +(defstruct layout-split + "A binary split of FIRST and SECOND. + +ORIENTATION is :HORIZONTAL or :VERTICAL. RATIO is the fraction of the usable +output assigned to FIRST, and must be strictly between zero and one." + orientation + ratio + first + second) + +(defstruct view + id + activity-id + name + (placements '()) + layout-root + ;; :MANUAL preserves an explicitly edited binary tree. :MASTER-STACK and + ;; :MONOCLE are built-in policies whose state belongs to the checkpoint too. + (layout-mode :manual) + layout-options + focus-client-id) + +(defstruct viewset-entry + "One saved target in a multi-Head Viewset. + +HEAD-ID is deliberately a durable logical identifier rather than a pixel +rectangle. Entries may be created before a matching physical Head exists; +activation, not saving, decides whether the current topology can satisfy it." + head-id + view-id) + +(defstruct viewset + "A named, explicit mapping from Heads to saved single-Head Views. + +A Viewset records only View selections. It never captures a mutable +Presentation draft or client Lease, so recalling it follows the same explicit +collision policy as ordinary View activation." + id + name + (entries '())) + +(defstruct head + "One independently addressable display rectangle. Its active Presentation is +the only Presentation that may hold leases for this Head." + id + active-presentation-id) + +(defstruct presentation + "A mutable Activity × Head working state. + +SOURCE-VIEW-ID identifies the checkpoint this was recalled from; NIL denotes +an unsaved draft. Missing leases are recorded separately from PLACEMENTS so a +partial activation never edits the saved checkpoint or silently erases slots." + id + head-id + activity-id + source-view-id + (placements '()) + layout-root + (layout-mode :manual) + layout-options + focus-client-id + (dirty-p nil) + (unavailable-client-ids '())) + +(defstruct lease + client-id + presentation-id) + +(defstruct activation-conflict + "A preflight finding. It is data for a menu, keybinding, REPL, or IPC client, +not an instruction to mutate state." + kind + client-id + view-id + holder-head-id + holder-presentation-id) + +(defstruct activation-report + world-revision + head-id + view-id + source-presentation-id + activity-id + current-presentation-id + (desired-placements '()) + desired-layout-root + (desired-layout-mode :manual) + desired-layout-options + focus-client-id + (conflicts '())) + +(defstruct activation-plan + base-revision + head-id + activity-id + source-view-id + target-presentation-id + outgoing-presentation-id + (desired-placements '()) + desired-layout-root + (layout-mode :manual) + layout-options + focus-client-id + (grant-client-ids '()) + (unavailable-client-ids '()) + (take-client-ids '()) + policy) + +(defstruct viewset-conflict + "One collision discovered while planning a whole Viewset activation." + kind + target-head-id + client-id + view-id + holder-head-id + holder-presentation-id) + +(defstruct viewset-report + "Read-only result of checking every target Head of one Viewset together." + world-revision + viewset-id + (entries '()) + ;; (HEAD-ID . ACTIVE-PRESENTATION-ID-OR-NIL), captured for stale-plan checks. + (outgoing-presentation-ids '()) + (conflicts '())) + +(defstruct viewset-plan + "A policy-selected, atomic multi-Head Viewset transition." + base-revision + viewset-id + policy + (entries '()) + (outgoing-presentation-ids '()) + ;; (HEAD-ID . CLIENT-IDS) for partial activation. + (unavailable-client-ids-by-head '()) + ;; Client ids currently held outside the Viewset's target Heads. + (take-client-ids '())) + +(defstruct viewset-result + "The observable outcome of an atomic Viewset activation." + viewset-id + ;; (HEAD-ID . PRESENTATION-ID) in the Viewset's saved entry order. + (presentation-ids '()) + ;; (HEAD-ID . CLIENT-IDS) omitted by partial activation, when any. + (unavailable-client-ids-by-head '())) + +(defstruct head-topology-source + "One removed Head with a live Presentation that needs an explicit decision." + head-id + presentation-id + activity-id + source-view-id) + +(defstruct head-topology-report + "A read-only comparison between current and desired logical Head ids." + world-revision + (current-head-ids '()) + (desired-head-ids '()) + (added-head-ids '()) + (retained-head-ids '()) + (removed-head-ids '()) + (removed-active-sources '())) + +(defstruct head-topology-move + "Move a disappearing Head's live Presentation to a desired Head." + from-head-id + to-head-id) + +(defstruct head-topology-plan + "A checked, explicit reconciliation of the core's logical Head set." + base-revision + (current-head-ids '()) + (desired-head-ids '()) + (added-head-ids '()) + (removed-head-ids '()) + (moves '())) + +(defstruct head-topology-result + "The observable outcome of committing a Head topology plan." + (moved-presentation-ids '()) + (suspended-presentation-ids '()) + (added-head-ids '()) + (removed-head-ids '())) + +(defun %touch (world) + (incf (world-revision world)) + world) + +(defun %lookup (table id kind) + (or (gethash id table) + (error 'unknown-entity :kind kind :id id))) + +(defun %ensure-fresh-id (table id kind) + (when (gethash id table) + (error 'invalid-transition + :description (format nil "A ~A named ~S already exists." kind id)))) + +(defun %copy-placement (placement) + (make-placement :client-id (placement-client-id placement) + :kind (placement-kind placement) + :data (if (eq (placement-kind placement) :float) + (%canonical-floating-placement-data + (placement-data placement)) + (copy-tree (placement-data placement))))) + +(defun %copy-placements (placements) + (mapcar #'%copy-placement placements)) + +(defun %copy-layout-root (layout-root) + (typecase layout-root + (null nil) + (layout-leaf + (make-layout-leaf :client-id (layout-leaf-client-id layout-root))) + (layout-split + (make-layout-split + :orientation (layout-split-orientation layout-root) + :ratio (layout-split-ratio layout-root) + :first (%copy-layout-root (layout-split-first layout-root)) + :second (%copy-layout-root (layout-split-second layout-root)))))) + +(defun layout-node-client-ids (layout-root) + "Return the tiled client ids referenced by LAYOUT-ROOT, left to right." + (typecase layout-root + (null '()) + (layout-leaf (list (layout-leaf-client-id layout-root))) + (layout-split (append (layout-node-client-ids (layout-split-first layout-root)) + (layout-node-client-ids (layout-split-second layout-root)))))) + +(defun %placement-client-ids (placements) + (mapcar #'placement-client-id placements)) + +(defun %placement-for-client (placements client-id) + (find client-id placements :key #'placement-client-id :test #'equal)) + +(defun %tiled-client-ids (placements) + (loop for placement in placements + when (eq (placement-kind placement) :tile) + collect (placement-client-id placement))) + +(defun %validate-layout-node (layout-root) + (typecase layout-root + (layout-leaf + (unless (layout-leaf-client-id layout-root) + (error 'invalid-transition :description "A layout leaf needs a client id."))) + (layout-split + (unless (member (layout-split-orientation layout-root) + '(:horizontal :vertical)) + (error 'invalid-transition + :description "A layout split must be :HORIZONTAL or :VERTICAL.")) + (unless (and (realp (layout-split-ratio layout-root)) + (< 0 (layout-split-ratio layout-root) 1)) + (error 'invalid-transition + :description "A layout split ratio must be strictly between zero and one.")) + (unless (and (layout-split-first layout-root) + (layout-split-second layout-root)) + (error 'invalid-transition + :description "A layout split needs two child nodes.")) + (%validate-layout-node (layout-split-first layout-root)) + (%validate-layout-node (layout-split-second layout-root))) + (otherwise + (error 'invalid-transition :description "Unknown layout node.")))) + +(defun %same-id-set-p (left right) + (and (= (length left) (length right)) + (every (lambda (id) (member id right :test #'equal)) left))) + +(defun %validate-layout-root (world activity-id placements layout-root) + (when layout-root + (%validate-layout-node layout-root) + (let ((layout-client-ids (layout-node-client-ids layout-root)) + (tiled-client-ids (%tiled-client-ids placements))) + (unless (= (length layout-client-ids) + (length (remove-duplicates layout-client-ids :test #'equal))) + (error 'invalid-transition + :description "A layout tree may not contain the same client twice.")) + (unless (%same-id-set-p layout-client-ids tiled-client-ids) + (error 'invalid-transition + :description + "A layout tree must contain exactly the tiled clients in its placements.")) + (dolist (client-id layout-client-ids) + (%ensure-client-in-activity world client-id activity-id))))) + +(defun %validate-layout-mode (layout-mode layout-options) + "Check the stable, backend-neutral layout-policy vocabulary. + +Detailed option interpretation belongs to the pure layout module; this layer +only guarantees that checkpoints and plans carry an ordinary property list." + (unless (member layout-mode '(:manual :master-stack :monocle)) + (error 'invalid-transition + :description "A layout mode must be :MANUAL, :MASTER-STACK, or :MONOCLE.")) + (unless (and (listp layout-options) + (evenp (length layout-options)) + (loop for tail on layout-options by #'cddr + always (keywordp (first tail)))) + (error 'invalid-transition + :description "Layout options must be a keyword property list.")) + (when (and layout-options (not (eq layout-mode :master-stack))) + (error 'invalid-transition + :description "Only :MASTER-STACK accepts layout options.")) + (when (eq layout-mode :master-stack) + (unless (every (lambda (key) + (member key '(:master-count :master-ratio :orientation))) + (loop for (key) on layout-options by #'cddr collect key)) + (error 'invalid-transition + :description "Unknown master/stack layout option.")) + (let ((master-count (getf layout-options :master-count 1)) + (master-ratio (getf layout-options :master-ratio 3/5)) + (orientation (getf layout-options :orientation :horizontal))) + (unless (and (integerp master-count) (plusp master-count)) + (error 'invalid-transition + :description "Master/stack :MASTER-COUNT must be a positive integer.")) + (unless (and (realp master-ratio) (< 0 master-ratio 1)) + (error 'invalid-transition + :description "Master/stack :MASTER-RATIO must be strictly between zero and one.")) + (unless (member orientation '(:horizontal :vertical)) + (error 'invalid-transition + :description "Master/stack :ORIENTATION must be :HORIZONTAL or :VERTICAL."))))) + +(defun %add-unique-id (id ids) + (if (member id ids :test #'equal) + ids + (append ids (list id)))) + +(defun %remove-id (id ids) + (remove id ids :test #'equal)) + +(defun find-activity (world id) + (%lookup (world-activities world) id :activity)) + +(defun find-client (world id) + (%lookup (world-clients world) id :client)) + +(defun find-view (world id) + (%lookup (world-views world) id :view)) + +(defun find-viewset (world id) + (%lookup (world-viewsets world) id :viewset)) + +(defun find-head (world id) + (%lookup (world-heads world) id :head)) + +(defun find-presentation (world id) + (%lookup (world-presentations world) id :presentation)) + +(defun list-activities (world) + "Return every Activity currently registered in WORLD. + +The core deliberately promises membership rather than an ordering; a UI can +sort stable display labels according to its own presentation policy." + (let (activities) + (maphash (lambda (id activity) + (declare (ignore id)) + (push activity activities)) + (world-activities world)) + activities)) + +(defun list-viewsets (world) + "Return every durable Viewset currently registered in WORLD. + +Like LIST-ACTIVITIES, this deliberately makes no ordering promise; a frontend +sorts display labels according to its own presentation policy." + (let (viewsets) + (maphash (lambda (id viewset) + (declare (ignore id)) + (push viewset viewsets)) + (world-viewsets world)) + viewsets)) + +(defun current-presentation (world head-id) + "Return HEAD-ID's active presentation, or NIL when it is blank." + (let ((presentation-id (head-active-presentation-id (find-head world head-id)))) + (and presentation-id (find-presentation world presentation-id)))) + +(defun lease-for-client (world client-id) + (gethash client-id (world-leases world))) + +(defun presentation-client-ids (presentation) + (%placement-client-ids (presentation-placements presentation))) + +(defun client-available-in-activity-p (world client-id activity-id) + "Sharing grants eligibility, never a lease. Every client still has one home." + (find-activity world activity-id) + (let ((client (find-client world client-id))) + (or (client-shared-p client) (equal (client-activity-id client) activity-id)))) + +(defun activity-available-client-ids (world activity-id) + "Home clients followed by shared guests, with no duplicate ids." + (let ((home (activity-client-ids (find-activity world activity-id)))) + (append (copy-list home) + (sort (loop for client being the hash-values of (world-clients world) + when (and (client-shared-p client) + (not (equal (client-activity-id client) activity-id))) + collect (client-id client)) + #'string< :key #'princ-to-string)))) + +(defun presentation-hidden-client-ids (world presentation) + "Return eligible home/shared clients omitted from PRESENTATION's placements. + +An Activity owns its clients independently of any one Head-local draft or +saved View. Thus a hidden client remains alive and available to a later +`SHOW-CLIENT-ON-PRESENTATION` call; it is neither minimized nor removed from +the Activity. A client with an unavailable placement is intentionally not in +this result: the Presentation already asks for that slot and may reclaim it +once its lease becomes free." + (let ((shown-client-ids (presentation-client-ids presentation))) + (loop for client-id in (activity-available-client-ids world (presentation-activity-id presentation)) + unless (member client-id shown-client-ids :test #'equal) + collect client-id))) + +(defun presentation-active-p (world presentation) + ;; A topology reconciliation can suspend a cached draft from a removed + ;; Head. Such a Presentation has no HEAD-ID until an explicit later resume + ;; binds it to a real Head again, and it must never be considered active. + (let ((head-id (presentation-head-id presentation))) + (and head-id + (let ((head (gethash head-id (world-heads world)))) + (and head + (equal (head-active-presentation-id head) + (presentation-id presentation))))))) + +(defun presentation-leased-client-ids (world presentation) + "Return the clients currently visible in PRESENTATION, in layout order." + (loop for placement in (presentation-placements presentation) + for client-id = (placement-client-id placement) + for lease = (lease-for-client world client-id) + when (and lease + (equal (lease-presentation-id lease) + (presentation-id presentation))) + collect client-id)) + +(defun create-head (world id) + "Register a Head. It starts with no active Presentation." + (%ensure-fresh-id (world-heads world) id :head) + (setf (gethash id (world-heads world)) (make-head :id id)) + (%touch world) + (find-head world id)) + +(defun create-activity (world id name) + "Create a durable task container." + (%ensure-fresh-id (world-activities world) id :activity) + (setf (gethash id (world-activities world)) + (make-activity :id id :name name)) + (%touch world) + (find-activity world id)) + +(defun create-client (world id activity-id &key name metadata (shared-p nil)) + "Create a client in ACTIVITY-ID's pool. It is parked until a presentation +explicitly asks to show it." + (%ensure-fresh-id (world-clients world) id :client) + (unless (member shared-p '(nil t)) + (error 'invalid-transition :description "SHARED-P must be T or NIL.")) + (let ((activity (find-activity world activity-id))) + (setf (gethash id (world-clients world)) + (make-client :id id + :activity-id activity-id + :shared-p shared-p + :name name + :metadata metadata)) + (setf (activity-client-ids activity) + (%add-unique-id id (activity-client-ids activity))) + (%touch world) + (find-client world id))) + +(defun %ensure-client-in-activity (world client-id activity-id) + (let ((client (find-client world client-id))) + (unless (client-available-in-activity-p world client-id activity-id) + (error 'invalid-activity-membership + :client-id client-id + :activity-id activity-id)) + client)) + +(defun %validate-placements (world activity-id placements) + (unless (every (lambda (placement) (typep placement 'placement)) placements) + (error 'invalid-transition :description "A view placement was not a PLACEMENT.")) + (dolist (placement placements) + (placement-tile-weight placement) + (unless (member (placement-kind placement) '(:tile :float)) + (error 'invalid-transition + :description "A placement kind must be :TILE or :FLOAT.")) + (when (eq (placement-kind placement) :float) + (%canonical-floating-placement-data (placement-data placement)))) + (let ((client-ids (%placement-client-ids placements))) + (unless (= (length client-ids) + (length (remove-duplicates client-ids :test #'equal))) + (error 'invalid-transition + :description "A layout may not contain the same client twice.")) + (dolist (client-id client-ids) + (%ensure-client-in-activity world client-id activity-id)))) + +(defun %activity-has-view-named-p (world activity name) + "Whether ACTIVITY already owns a View with human-facing NAME. + +View ids are machine identities, but `Activity:View` is Lime's human-facing +address. Case-insensitive uniqueness within that Activity keeps menus, +commands, and spoken names unambiguous while allowing every other Activity to +have its own `Inbox`, `Code`, or `Debug` checkpoint." + (loop for view-id in (activity-view-ids activity) + for view = (find-view world view-id) + thereis (equalp name (view-name view)))) + +(defun create-view (world id activity-id name placements + &key layout-root (layout-mode :manual) layout-options + focus-client-id) + "Save a named, single-Head checkpoint. + +PLACEMENTS contains only windows the View requests to display. A client absent +from a View is not globally hidden; another Head may still lease it." + (%ensure-fresh-id (world-views world) id :view) + (let ((activity (find-activity world activity-id))) + (when (%activity-has-view-named-p world activity name) + (error 'invalid-transition + :description + (format nil "Activity ~S already has a View named ~S." + activity-id name))) + (%validate-placements world activity-id placements) + (%validate-layout-root world activity-id placements layout-root) + (%validate-layout-mode layout-mode layout-options) + (when focus-client-id + (%ensure-client-in-activity world focus-client-id activity-id)) + (setf (gethash id (world-views world)) + (make-view :id id + :activity-id activity-id + :name name + :placements (%copy-placements placements) + :layout-root (%copy-layout-root layout-root) + :layout-mode layout-mode + :layout-options (copy-tree layout-options) + :focus-client-id focus-client-id)) + (setf (activity-view-ids activity) + (%add-unique-id id (activity-view-ids activity))) + (%touch world) + (find-view world id))) + +(defun %copy-viewset-entries (entries) + (mapcar (lambda (entry) + (make-viewset-entry :head-id (viewset-entry-head-id entry) + :view-id (viewset-entry-view-id entry))) + entries)) + +(defun %validate-viewset-entries (world entries) + "Validate a durable Head -> View mapping without requiring current Heads. + +The saved mapping may outlive a dock, laptop panel, or temporary monitor. A +missing physical Head is therefore an activation-time error, not a reason to +reject the useful named shortcut at save time." + (unless (and (listp entries) entries + (every (lambda (entry) (typep entry 'viewset-entry)) entries)) + (error 'invalid-transition + :description "A Viewset needs at least one VIEWSET-ENTRY.")) + (let ((head-ids (mapcar #'viewset-entry-head-id entries)) + (view-ids (mapcar #'viewset-entry-view-id entries))) + (unless (and (every #'identity head-ids) + (= (length head-ids) + (length (remove-duplicates head-ids :test #'equal)))) + (error 'invalid-transition + :description "A Viewset may name each Head only once.")) + (unless (and (every #'identity view-ids) + (= (length view-ids) + (length (remove-duplicates view-ids :test #'equal)))) + (error 'invalid-transition + :description "A Viewset may mount each named View only once.")) + (dolist (view-id view-ids) + (find-view world view-id))) + entries) + +(defun create-viewset (world id name entries) + "Save NAME as an explicit mapping of logical Heads to named Views. + +The operation does not activate anything and does not capture mutable live +drafts. Use the Viewset planner to decide the later multi-Head recall policy." + (%ensure-fresh-id (world-viewsets world) id :viewset) + (%validate-viewset-entries world entries) + (setf (gethash id (world-viewsets world)) + (make-viewset :id id :name name :entries (%copy-viewset-entries entries))) + (%touch world) + (find-viewset world id)) diff --git a/src/operations.lisp b/src/operations.lisp new file mode 100644 index 0000000..6fb5a6f --- /dev/null +++ b/src/operations.lisp @@ -0,0 +1,1125 @@ +(in-package #:lime.core) + +;;;; Queries and preflight + +(defun %active-presentations (world) + (let (presentations) + (maphash (lambda (head-id head) + (declare (ignore head-id)) + (let ((presentation-id (head-active-presentation-id head))) + (when presentation-id + (push (find-presentation world presentation-id) presentations)))) + (world-heads world)) + presentations)) + +(defun %conflicts-of-kind (report kind) + (remove-if-not (lambda (conflict) + (eq (activation-conflict-kind conflict) kind)) + (activation-report-conflicts report))) + +(defun activation-report-ready-p (report) + (null (activation-report-conflicts report))) + +(defun %preflight-activation (world head-id activity-id source-view-id + source-presentation-id placements layout-root + layout-mode layout-options focus-client-id) + (let* ((head (find-head world head-id)) + (current-presentation-id (head-active-presentation-id head)) + (conflicts '())) + ;; A named View is a single-Head checkpoint. Its saved definition may + ;; be referenced by arbitrary inactive presentations, but it may only be + ;; mounted by one active Head at a time. + (when source-view-id + (dolist (presentation (%active-presentations world)) + (when (and (equal (presentation-source-view-id presentation) + source-view-id) + (not (equal (presentation-head-id presentation) head-id))) + (push (make-activation-conflict + :kind :view-mounted + :view-id source-view-id + :holder-head-id (presentation-head-id presentation) + :holder-presentation-id (presentation-id presentation)) + conflicts)))) + ;; A placement asks for a real client. A client leased by the currently + ;; active presentation on the target Head is harmless: that presentation + ;; will be replaced as part of the transition. Any other lease is a real + ;; cross-Head collision. + (dolist (placement placements) + (let* ((client-id (placement-client-id placement)) + (lease (lease-for-client world client-id))) + (when (and lease + (not (equal (lease-presentation-id lease) + current-presentation-id))) + (let ((holder (find-presentation world + (lease-presentation-id lease)))) + (push (make-activation-conflict + :kind :client-leased + :client-id client-id + :holder-head-id (presentation-head-id holder) + :holder-presentation-id (presentation-id holder)) + conflicts))))) + (make-activation-report + :world-revision (world-revision world) + :head-id head-id + :view-id source-view-id + :source-presentation-id source-presentation-id + :activity-id activity-id + :current-presentation-id current-presentation-id + :desired-placements (%copy-placements placements) + :desired-layout-root (%copy-layout-root layout-root) + :desired-layout-mode layout-mode + :desired-layout-options (copy-tree layout-options) + :focus-client-id focus-client-id + :conflicts (nreverse conflicts)))) + +(defun preflight-view-activation (world head-id view-id) + "Inspect a saved View activation without changing WORLD. + +The returned report is intentionally UI-neutral. A keyboard command, command +palette, IPC client, or Lisp REPL can choose strict, partial, or explicit-take +behavior from the same collision data." + (let ((view (find-view world view-id))) + (%preflight-activation world + head-id + (view-activity-id view) + view-id + nil + (view-placements view) + (view-layout-root view) + (view-layout-mode view) + (view-layout-options view) + (view-focus-client-id view)))) + +(defun preflight-presentation-resume (world head-id presentation-id) + "Inspect resuming a cached Presentation on HEAD-ID. + +Unlike recalling a View, resume keeps the Presentation's dirty layout and +draft-only windows. A normally cached Presentation resumes only on its former +Head; a topology-suspended Presentation has no former Head and can explicitly +resume on any current Head. Resume requests current locations only; it never +retries missing slots from an older partial checkpoint recall." + (let ((presentation (find-presentation world presentation-id))) + (unless (or (null (presentation-head-id presentation)) + (equal (presentation-head-id presentation) head-id)) + (error 'invalid-transition + :description "A cached presentation may only resume on its own Head unless topology reconciliation suspended it.")) + ;; Missing slots belong to an explicit checkpoint recall, not to the live + ;; arrangement. Returning to an Activity must not retry an old request. + (let ((copy (copy-presentation presentation))) + (dolist (id (presentation-unavailable-client-ids presentation)) + (%remove-client-from-container copy id)) + (%preflight-activation world + head-id + (presentation-activity-id presentation) + (presentation-source-view-id presentation) + presentation-id + (presentation-placements copy) + (presentation-layout-root copy) + (presentation-layout-mode presentation) + (presentation-layout-options presentation) + (presentation-focus-client-id presentation))))) + +(defun activity-draft-for-head (world activity-id head-id) + "Return ACTIVITY-ID's current working arrangement for HEAD-ID, if any. + +The historical name is kept for API compatibility. A recalled View edits this +same live arrangement; it does not create a second workspace behind it." + (find-if (lambda (presentation) + (and (equal (presentation-activity-id presentation) activity-id) + (equal (presentation-head-id presentation) head-id))) + (let (presentations) + (maphash (lambda (presentation-id presentation) + (declare (ignore presentation-id)) + (push presentation presentations)) + (world-presentations world)) + presentations))) + +(defun preflight-activity-draft (world head-id activity-id + &key (default-layout :manual)) + "Inspect opening ACTIVITY-ID's live draft on HEAD-ID without mutation. + +An existing Head-local draft resumes with its exact runtime arrangement. A +first visit instead preflights an empty unsaved Presentation in DEFAULT-LAYOUT. +An existing arrangement keeps its layout regardless of that default. Both +paths use the ordinary activation report, but unique live locations mean that +normal Activity navigation never competes for another Head's windows." + (find-head world head-id) + (find-activity world activity-id) + (%validate-layout-mode default-layout nil) + (let ((draft (activity-draft-for-head world activity-id head-id))) + (if draft + (preflight-presentation-resume world head-id (presentation-id draft)) + (multiple-value-bind (count ratio orientation) (%master-stack-options nil) + (%preflight-activation + world head-id activity-id nil nil '() nil default-layout + (when (eq default-layout :master-stack) + (list :master-count count :master-ratio ratio :orientation orientation)) + nil))))) + +;;;; Plan construction + +(defun %require-no-view-mount-conflict (report) + (when (%conflicts-of-kind report :view-mounted) + (error 'activation-blocked :report report))) + +(defun %make-plan-from-report (report policy grant-client-ids + unavailable-client-ids take-client-ids) + (make-activation-plan + :base-revision (activation-report-world-revision report) + :head-id (activation-report-head-id report) + :activity-id (activation-report-activity-id report) + :source-view-id (activation-report-view-id report) + :target-presentation-id (activation-report-source-presentation-id report) + :outgoing-presentation-id (activation-report-current-presentation-id report) + :desired-placements (%copy-placements + (activation-report-desired-placements report)) + :desired-layout-root (%copy-layout-root + (activation-report-desired-layout-root report)) + :layout-mode (activation-report-desired-layout-mode report) + :layout-options (copy-tree (activation-report-desired-layout-options report)) + :focus-client-id (activation-report-focus-client-id report) + :grant-client-ids grant-client-ids + :unavailable-client-ids unavailable-client-ids + :take-client-ids take-client-ids + :policy policy)) + +(defun build-strict-activation-plan (report) + "Build a no-surprises plan. It either has every requested client or signals +ACTIVATION-BLOCKED without changing the model." + (unless (activation-report-ready-p report) + (error 'activation-blocked :report report)) + (%make-plan-from-report report + :strict + (%placement-client-ids + (activation-report-desired-placements report)) + '() + '())) + +(defun build-partial-activation-plan (report) + "Build a reduced plan that claims only currently free clients. + +View-mount conflicts remain blocking: a named View is never cloned to two +Heads. Client collisions become unavailable slots in the new presentation." + (%require-no-view-mount-conflict report) + (let* ((blocked (mapcar #'activation-conflict-client-id + (%conflicts-of-kind report :client-leased))) + (grant (remove-if (lambda (client-id) + (member client-id blocked :test #'equal)) + (%placement-client-ids + (activation-report-desired-placements report))))) + (%make-plan-from-report report + :partial + grant + blocked + '()))) + +(defun build-taking-activation-plan (report) + "Build a plan that explicitly transfers all colliding client leases. + +This is a distinct command from partial activation. It does not alter either +saved View; transferred clients leave their previous live locations." + (%require-no-view-mount-conflict report) + (let ((taken (mapcar #'activation-conflict-client-id + (%conflicts-of-kind report :client-leased)))) + (%make-plan-from-report report + :take + (%placement-client-ids + (activation-report-desired-placements report)) + '() + taken))) + +;;;; Commit helpers + +(defun %leases-held-by-presentation (world presentation-id) + (let (client-ids) + (maphash (lambda (client-id lease) + (when (equal (lease-presentation-id lease) presentation-id) + (push client-id client-ids))) + (world-leases world)) + client-ids)) + +(defun %release-presentation-leases (world presentation) + (dolist (client-id (%leases-held-by-presentation world + (presentation-id presentation))) + (remhash client-id (world-leases world)))) + +(defun %mark-client-unavailable (presentation client-id) + (setf (presentation-unavailable-client-ids presentation) + (%add-unique-id client-id + (presentation-unavailable-client-ids presentation)) + (presentation-dirty-p presentation) t) + ;; A focus target that has just been transferred cannot be restored locally. + (when (equal (presentation-focus-client-id presentation) client-id) + (setf (presentation-focus-client-id presentation) nil))) + +(defun %remove-client-from-unavailable (presentation client-id) + (setf (presentation-unavailable-client-ids presentation) + (%remove-id client-id (presentation-unavailable-client-ids presentation)))) + +(defun %fresh-presentation-id (world) + (format nil "presentation-~D" (incf (world-next-presentation-number world)))) + +(defun %focus-from-grants (requested-focus grant-client-ids) + (if (member requested-focus grant-client-ids :test #'equal) + requested-focus + (first grant-client-ids))) + +(defun %assert-plan-current (world plan) + (unless (= (activation-plan-base-revision plan) (world-revision world)) + (error 'stale-transition-plan)) + (let ((head (find-head world (activation-plan-head-id plan)))) + (unless (equal (head-active-presentation-id head) + (activation-plan-outgoing-presentation-id plan)) + (error 'stale-transition-plan)))) + +(defun %assert-plan-placements (world plan) + (%validate-placements world + (activation-plan-activity-id plan) + (activation-plan-desired-placements plan)) + (%validate-layout-root world + (activation-plan-activity-id plan) + (activation-plan-desired-placements plan) + (activation-plan-desired-layout-root plan)) + (%validate-layout-mode (activation-plan-layout-mode plan) + (activation-plan-layout-options plan)) + (dolist (client-id (activation-plan-grant-client-ids plan)) + (unless (%placement-for-client (activation-plan-desired-placements plan) + client-id) + (error 'invalid-transition + :description "An activation plan tried to lease an unplaced client.")))) + +(defun %transfer-away-from-incumbent (world client-id) + (let ((lease (lease-for-client world client-id))) + (when lease + (let ((incumbent (find-presentation world + (lease-presentation-id lease)))) + (remhash client-id (world-leases world)) + (%remove-live-placement world incumbent client-id))))) + +(defun %remove-live-placement (world presentation client-id) + "Remove a current location, preserving the saved checkpoint and focus order." + (when (%placement-for-client (presentation-placements presentation) client-id) + (let ((old-ids (presentation-client-ids presentation)) + (focused-p (equal client-id (presentation-focus-client-id presentation)))) + (%remove-client-from-container presentation client-id) + (%remove-client-from-unavailable presentation client-id) + (when focused-p + (setf (presentation-focus-client-id presentation) + (%focus-replacement-after-removal + old-ids client-id + (if (presentation-active-p world presentation) + (presentation-leased-client-ids world presentation) + (set-difference (presentation-client-ids presentation) + (presentation-unavailable-client-ids presentation) :test #'equal)) + :previous))) + (setf (presentation-dirty-p presentation) t)))) + +(defun %claim-live-locations (world target client-ids) + "Relocation, not a loan: forget every previous live location, even inactive. + +Checkpoint definitions are never touched. Caller must first resolve any real +cross-Head lease explicitly; this helper cannot authorize stealing a window." + (dolist (id client-ids) + (let ((lease (lease-for-client world id))) + (when (and lease (not (equal (lease-presentation-id lease) (presentation-id target)))) + (%invalid "Cannot relocate leased client ~S without an explicit transfer." id)))) + (maphash + (lambda (id other) + (unless (equal id (presentation-id target)) + (dolist (client-id client-ids) (%remove-live-placement world other client-id)) + ;; A checkpoint recalled elsewhere is no longer the source label of + ;; this older live arrangement. Its layout still survives independently. + (when (and (presentation-source-view-id target) + (equal (presentation-source-view-id target) (presentation-source-view-id other))) + (setf (presentation-source-view-id other) nil + (presentation-dirty-p other) t)))) + (world-presentations world))) + +(defun commit-activation-plan (world plan) + "Apply a previously built plan as one logical transition. + +The eventual CLX backend will turn this state transition into an ordered batch +of map, unmap, configure, stack, and focus requests. This layer deliberately +does none of those effects." + (%assert-plan-current world plan) + (%assert-plan-placements world plan) + (let* ((head (find-head world (activation-plan-head-id plan))) + (outgoing-id (activation-plan-outgoing-presentation-id plan)) + (outgoing (and outgoing-id (find-presentation world outgoing-id)))) + ;; First release the target Head's old leases. Its presentation remains + ;; cached as an independent draft, ready for a later resume operation. + (when outgoing + (%release-presentation-leases world outgoing) + (setf (head-active-presentation-id head) nil)) + ;; A :TAKE plan transfers only the collisions reported during preflight. + ;; Incumbent live locations are removed; no saved View is modified. + (dolist (client-id (activation-plan-take-client-ids plan)) + (%transfer-away-from-incumbent world client-id)) + (let* ((target-presentation-id (activation-plan-target-presentation-id plan)) + (grant-client-ids (activation-plan-grant-client-ids plan)) + (presentation + (if target-presentation-id + (find-presentation world target-presentation-id) + (or (activity-draft-for-head world (activation-plan-activity-id plan) + (activation-plan-head-id plan)) + (make-presentation :id (%fresh-presentation-id world))))) + (presentation-id (presentation-id presentation)) + (was-dirty-p (and target-presentation-id (presentation-dirty-p presentation)))) + ;; A cached Presentation is local to its Head. Resuming it restores the + ;; exact object, including draft-only windows and layout changes, rather + ;; than manufacturing another copy of its source View. + (when (and target-presentation-id + (presentation-head-id presentation) + (not (equal (presentation-head-id presentation) + (activation-plan-head-id plan)))) + (error 'invalid-transition + :description "An activation plan tried to mount a presentation on another Head.")) + (setf (presentation-head-id presentation) (activation-plan-head-id plan) + (presentation-activity-id presentation) (activation-plan-activity-id plan) + (presentation-source-view-id presentation) (activation-plan-source-view-id plan) + (presentation-placements presentation) + (%copy-placements (activation-plan-desired-placements plan)) + (presentation-layout-root presentation) + (%copy-layout-root (activation-plan-desired-layout-root plan)) + (presentation-layout-mode presentation) + (activation-plan-layout-mode plan) + (presentation-layout-options presentation) + (copy-tree (activation-plan-layout-options plan)) + (presentation-focus-client-id presentation) + (%focus-from-grants (activation-plan-focus-client-id plan) + grant-client-ids) + (presentation-dirty-p presentation) + (or was-dirty-p + (not (null (activation-plan-unavailable-client-ids plan)))) + (presentation-unavailable-client-ids presentation) + (copy-list (activation-plan-unavailable-client-ids plan))) + (setf (gethash presentation-id (world-presentations world)) presentation + (head-active-presentation-id head) presentation-id) + ;; Explicitly resuming a topology-suspended arrangement can replace an + ;; existing one on this Head. Keep the displaced arrangement suspended. + (maphash (lambda (id other) + (when (and (not (equal id presentation-id)) + (equal (presentation-head-id other) (presentation-head-id presentation)) + (equal (presentation-activity-id other) (presentation-activity-id presentation))) + (setf (presentation-head-id other) nil))) + (world-presentations world)) + (%claim-live-locations world presentation grant-client-ids) + (dolist (client-id grant-client-ids) + ;; Any remaining lease would mean an invalid or stale plan. We refuse + ;; to silently select a last writer and preserve the one-lease rule. + (when (lease-for-client world client-id) + (error 'invalid-transition + :description "Activation would give a client two leases.")) + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id + :presentation-id presentation-id))) + (%touch world) + presentation))) + +;;;; Public commands + +(defun activate-view-strictly (world head-id view-id) + "Recall VIEW-ID on HEAD-ID only when no conflict exists." + (commit-activation-plan + world + (build-strict-activation-plan + (preflight-view-activation world head-id view-id)))) + +(defun activate-view-partially (world head-id view-id) + "Recall VIEW-ID on HEAD-ID without taking clients leased elsewhere." + (commit-activation-plan + world + (build-partial-activation-plan + (preflight-view-activation world head-id view-id)))) + +(defun activate-view-taking (world head-id view-id) + "Recall VIEW-ID on HEAD-ID and explicitly take colliding client leases." + (commit-activation-plan + world + (build-taking-activation-plan + (preflight-view-activation world head-id view-id)))) + +(defun resume-presentation-strictly (world head-id presentation-id) + "Resume a cached draft only when every requested client is available." + (commit-activation-plan + world + (build-strict-activation-plan + (preflight-presentation-resume world head-id presentation-id)))) + +(defun resume-presentation-partially (world head-id presentation-id) + "Resume a cached draft without taking clients leased on another Head." + (commit-activation-plan + world + (build-partial-activation-plan + (preflight-presentation-resume world head-id presentation-id)))) + +(defun resume-presentation-taking (world head-id presentation-id) + "Resume a cached draft and explicitly take its colliding clients." + (commit-activation-plan + world + (build-taking-activation-plan + (preflight-presentation-resume world head-id presentation-id)))) + +(defun open-activity-draft (world head-id activity-id + &key (policy :strict) (default-layout :manual)) + "Open or resume ACTIVITY-ID's current working arrangement on HEAD-ID. + +POLICY has the same explicit meanings as View activation: :STRICT rejects a +cross-Head client collision, :PARTIAL leaves contested slots elsewhere, and +:TAKE transfers them. Unique current locations make normal Activity resumes +collision-free. A first visit is empty and does not gather windows from elsewhere. +DEFAULT-LAYOUT applies only to that first draft, never to a resumed one." + (let ((report (preflight-activity-draft world head-id activity-id + :default-layout default-layout))) + (commit-activation-plan + world + (ecase policy + (:strict (build-strict-activation-plan report)) + (:partial (build-partial-activation-plan report)) + (:take (build-taking-activation-plan report)))))) + +(defun %valid-tiled-insertion-position-p (position) + (member position '(:front :back))) + +(defun %valid-focus-direction-p (direction) + (member direction '(:previous :next))) + +(defun %insert-tiled-client-into-layout (presentation client-id + &key (position :back)) + "Add CLIENT-ID to a manual layout tree at POSITION. + +The placement list remains the durable ordering authority. Master/stack +rebuilds from that list; this helper only keeps a manual tree in step." + (unless (%valid-tiled-insertion-position-p position) + (error 'invalid-transition + :description "Tiled insertion position must be :FRONT or :BACK.")) + (let ((layout-root (presentation-layout-root presentation))) + (if layout-root + (ecase position + (:front + (make-layout-split :orientation :horizontal + :ratio 1/2 + :first (make-layout-leaf :client-id client-id) + :second layout-root)) + (:back + (make-layout-split :orientation :horizontal + :ratio 1/2 + :first layout-root + :second (make-layout-leaf :client-id client-id)))) + (default-layout-root + (%tiled-client-ids (presentation-placements presentation)))))) + +(defun %remove-client-from-layout (layout-root client-id) + "Return LAYOUT-ROOT with CLIENT-ID's leaf removed. + +When one side of a split disappears, its surviving sibling takes that split's +place. This is the smallest useful policy for a closed client; later layout +engines may preserve more structural history if that proves desirable." + (typecase layout-root + (null nil) + (layout-leaf + (unless (equal (layout-leaf-client-id layout-root) client-id) + layout-root)) + (layout-split + (let ((first (%remove-client-from-layout (layout-split-first layout-root) + client-id)) + (second (%remove-client-from-layout (layout-split-second layout-root) + client-id))) + (cond ((and first second) + (make-layout-split :orientation (layout-split-orientation layout-root) + :ratio (layout-split-ratio layout-root) + :first first + :second second)) + (first first) + (second second)))))) + +(defun %remove-client-from-container (container client-id) + "Remove CLIENT-ID from a View or Presentation in place." + (setf (slot-value container 'placements) + (remove client-id (slot-value container 'placements) + :key #'placement-client-id :test #'equal) + (slot-value container 'layout-root) + (%remove-client-from-layout (slot-value container 'layout-root) client-id)) + ;; Built-in master/stack is an ongoing placement policy, not merely the + ;; tree it happened to produce before a client died. + (when (eq (slot-value container 'layout-mode) :master-stack) + (setf (slot-value container 'layout-root) + (layout-root-for-mode :master-stack + (slot-value container 'layout-options) + (slot-value container 'placements)))) + container) + +(defun %focus-replacement-after-removal + (ordered-client-ids removed-client-id surviving-client-ids direction) + "Choose the closest surviving client in DIRECTION from a removed slot. + +Placement order runs from master toward the bottom of the stack. Thus +:PREVIOUS means toward master and :NEXT means farther down the stack. The +opposite direction is a natural fallback at either edge." + (unless (%valid-focus-direction-p direction) + (error 'invalid-transition + :description "Focus direction must be :PREVIOUS or :NEXT.")) + (let ((position (position removed-client-id ordered-client-ids :test #'equal))) + (when position + (let* ((before (reverse (subseq ordered-client-ids 0 position))) + (after (nthcdr (1+ position) ordered-client-ids)) + (candidates (ecase direction + (:previous (append before after)) + (:next (append after before))))) + (find-if (lambda (client-id) + (member client-id surviving-client-ids :test #'equal)) + candidates))))) + +(defun %focus-direction-for-container (focus-direction container) + "Resolve a removal focus policy for one View or Presentation. + +FOCUS-DIRECTION is either :PREVIOUS/:NEXT or a function of CONTAINER. The +function form lets an adapter select a policy from the container's current +layout mode while keeping this protocol-independent core free of user config." + (let ((direction (if (functionp focus-direction) + (funcall focus-direction container) + focus-direction))) + (unless (%valid-focus-direction-p direction) + (error 'invalid-transition + :description "Focus direction must be :PREVIOUS or :NEXT.")) + direction)) + +(defun retire-client (world client-id &key (focus-direction :previous)) + "Forget a client that has permanently gone away. + +Unlike hiding a client in a View, retirement is global: a destroyed X11 +window cannot be restored later, so it is removed from its Activity pool, +every saved View, every live or cached Presentation, and its lease. + +FOCUS-DIRECTION is a direction or a function of each affected View or +Presentation, returning :PREVIOUS or :NEXT." + (unless (or (%valid-focus-direction-p focus-direction) + (functionp focus-direction)) + (error 'invalid-transition + :description "Focus direction must be :PREVIOUS, :NEXT, or a function.")) + (let ((client (find-client world client-id))) + (maphash (lambda (view-id view) + (declare (ignore view-id)) + (let ((old-client-ids + (mapcar #'placement-client-id (view-placements view))) + (old-focus-client-id (view-focus-client-id view)) + (container-focus-direction + (%focus-direction-for-container focus-direction view))) + (%remove-client-from-container view client-id) + (when (equal old-focus-client-id client-id) + (setf (view-focus-client-id view) + (%focus-replacement-after-removal + old-client-ids client-id + (mapcar #'placement-client-id (view-placements view)) + container-focus-direction))))) + (world-views world)) + (maphash (lambda (presentation-id presentation) + (declare (ignore presentation-id)) + (let ((old-client-ids (presentation-client-ids presentation)) + (old-focus-client-id + (presentation-focus-client-id presentation)) + (container-focus-direction + (%focus-direction-for-container focus-direction presentation))) + (%remove-client-from-container presentation client-id) + (setf (presentation-unavailable-client-ids presentation) + (%remove-id client-id + (presentation-unavailable-client-ids presentation)) + (presentation-dirty-p presentation) t) + (when (equal old-focus-client-id client-id) + (setf (presentation-focus-client-id presentation) + (%focus-replacement-after-removal + old-client-ids client-id + (presentation-client-ids presentation) + container-focus-direction))) + ;; A cached presentation can retain a focus preference for a + ;; parked client. An active Head cannot: its focus must name + ;; a client it actually leases. + (when (presentation-active-p world presentation) + (let ((focus-client-id (presentation-focus-client-id presentation))) + (unless (and focus-client-id + (let ((lease (lease-for-client world focus-client-id))) + (and lease + (equal (lease-presentation-id lease) + (presentation-id presentation))))) + (setf (presentation-focus-client-id presentation) + (or (and (equal old-focus-client-id client-id) + (%focus-replacement-after-removal + old-client-ids client-id + (presentation-leased-client-ids world presentation) + container-focus-direction)) + (first (presentation-leased-client-ids + world presentation))))))))) + (world-presentations world)) + (remhash client-id (world-leases world)) + (let ((activity (find-activity world (client-activity-id client)))) + (setf (activity-client-ids activity) + (%remove-id client-id (activity-client-ids activity)))) + (remhash client-id (world-clients world)) + (%touch world) + client-id)) + +(defun transfer-client-lease (world client-id target-presentation-id) + "General-purpose, explicit transfer command for one real client window. + +TARGET-PRESENTATION-ID must be active and already contain a placement for the +client. The caller can use SHOW-CLIENT-ON-PRESENTATION first to add an +unsaved placement." + (let* ((client (find-client world client-id)) + (target (find-presentation world target-presentation-id))) + (unless (presentation-active-p world target) + (error 'invalid-transition + :description "A client may only be leased to an active presentation.")) + (%ensure-client-in-activity world client-id + (presentation-activity-id target)) + (unless (%placement-for-client (presentation-placements target) client-id) + (error 'invalid-transition + :description "The target presentation has no placement for this client.")) + (let ((old-lease (lease-for-client world client-id))) + (unless (and old-lease + (equal (lease-presentation-id old-lease) + target-presentation-id)) + (when old-lease + (%transfer-away-from-incumbent world client-id)) + (%claim-live-locations world target (list client-id)) + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id + :presentation-id target-presentation-id)) + (%remove-client-from-unavailable target client-id) + (when (null (presentation-focus-client-id target)) + (setf (presentation-focus-client-id target) client-id)) + (%touch world))) + client)) + +(defun reclaim-available-slots (world presentation-id) + "Explicitly fill missing slots that have become free. + +Lime never auto-awards a freed client to a waiting presentation: that would +make windows jump monitors. A caller invokes this command when it wants a +partial presentation to try again." + (let ((presentation (find-presentation world presentation-id)) + (reclaimed '())) + (unless (presentation-active-p world presentation) + (error 'invalid-transition + :description "Only an active presentation can reclaim windows.")) + (dolist (placement (presentation-placements presentation)) + (let ((client-id (placement-client-id placement))) + (when (and (member client-id + (presentation-unavailable-client-ids presentation) + :test #'equal) + (null (lease-for-client world client-id))) + (%claim-live-locations world presentation (list client-id)) + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id + :presentation-id presentation-id)) + (%remove-client-from-unavailable presentation client-id) + (push client-id reclaimed)))) + (when reclaimed + (when (null (presentation-focus-client-id presentation)) + (setf (presentation-focus-client-id presentation) (first reclaimed))) + (%touch world)) + (nreverse reclaimed))) + +(defun show-client-on-presentation (world client-id presentation-id + &key (kind :tile) data + (tiled-insertion-position :back) + (focus-p nil)) + "Add CLIENT-ID to an active presentation's unsaved draft. + +This is the new-window path: it changes the live draft only, never historical +Views. If another Head currently leases the client, the new placement is +marked unavailable rather than stealing it. TILED-INSERTION-POSITION is +:BACK (least prominent) or :FRONT (master-most); FOCUS-P takes focus only +when this Presentation successfully owns the client's lease." + (unless (%valid-tiled-insertion-position-p tiled-insertion-position) + (error 'invalid-transition + :description "Tiled insertion position must be :FRONT or :BACK.")) + (unless (member focus-p '(t nil)) + (error 'invalid-transition :description "FOCUS-P must be T or NIL.")) + (let* ((presentation (find-presentation world presentation-id)) + (client (find-client world client-id))) + (declare (ignore client)) + (unless (presentation-active-p world presentation) + (error 'invalid-transition + :description "Only an active presentation can show a client.")) + (%ensure-client-in-activity world client-id + (presentation-activity-id presentation)) + (let ((placement-added-p nil)) + (unless (%placement-for-client (presentation-placements presentation) + client-id) + (let ((placement (make-placement :client-id client-id + :kind kind + :data (if (eq kind :float) + (%canonical-floating-placement-data data) + (copy-tree data))))) + (placement-tile-weight placement) + (setf (presentation-placements presentation) + (if (and (eq kind :tile) + (eq tiled-insertion-position :front)) + (cons placement (presentation-placements presentation)) + (append (presentation-placements presentation) + (list placement))) + placement-added-p t))) + (when (and placement-added-p (eq kind :tile)) + (setf (presentation-layout-root presentation) + (%insert-tiled-client-into-layout + presentation client-id :position tiled-insertion-position)) + (when (eq (presentation-layout-mode presentation) :master-stack) + (setf (presentation-layout-root presentation) + (layout-root-for-mode (presentation-layout-mode presentation) + (presentation-layout-options presentation) + (presentation-placements presentation)))))) + (let ((lease (lease-for-client world client-id))) + (cond + ((null lease) + (%claim-live-locations world presentation (list client-id)) + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id + :presentation-id presentation-id)) + (%remove-client-from-unavailable presentation client-id)) + ((equal (lease-presentation-id lease) presentation-id) + nil) + (t + (%mark-client-unavailable presentation client-id)))) + (when (and (or focus-p + (null (presentation-focus-client-id presentation))) + (let ((assigned-lease (lease-for-client world client-id))) + (and assigned-lease + (equal (lease-presentation-id assigned-lease) + presentation-id)))) + (setf (presentation-focus-client-id presentation) client-id)) + (setf (presentation-dirty-p presentation) t) + (%touch world) + presentation)) + +(defun hide-client-from-presentation (world client-id presentation-id + &key (focus-direction :previous)) + "Hide CLIENT-ID from an active Presentation's live draft. + +Hiding removes only this Head-local placement and any lease held by that +Presentation. The client remains a member of its Activity, and saved Views +remain unchanged; a later `SHOW-CLIENT-ON-PRESENTATION` can reveal it in a +different draft or arrangement. If CLIENT-ID was merely an unavailable +cross-Head slot, this operation drops that local request without disturbing +the real lease on the other Head. FOCUS-DIRECTION uses the same placement +ordering as RETIRE-CLIENT when the hidden client was focused." + (unless (%valid-focus-direction-p focus-direction) + (error 'invalid-transition + :description "Focus direction must be :PREVIOUS or :NEXT.")) + (let ((presentation (%require-active-presentation world presentation-id))) + (find-client world client-id) + (%ensure-client-in-activity world client-id + (presentation-activity-id presentation)) + (unless (%placement-for-client (presentation-placements presentation) + client-id) + (error 'invalid-transition + :description "The client is already hidden in this presentation.")) + (let ((old-client-ids (presentation-client-ids presentation)) + (old-focus-client-id (presentation-focus-client-id presentation))) + (%remove-client-from-container presentation client-id) + (when (equal old-focus-client-id client-id) + (setf (presentation-focus-client-id presentation) + (%focus-replacement-after-removal + old-client-ids client-id (presentation-client-ids presentation) + focus-direction)))) + (%remove-client-from-unavailable presentation client-id) + (let ((lease (lease-for-client world client-id))) + (when (and lease + (equal (lease-presentation-id lease) presentation-id)) + (remhash client-id (world-leases world)))) + ;; A removed focus target must not leave an active Head pointing at a + ;; parked or cross-Head client. The nearest slot toward master is used + ;; when possible; nil is right for an otherwise empty draft. + (let* ((focus-client-id (presentation-focus-client-id presentation)) + (focus-lease (and focus-client-id + (lease-for-client world focus-client-id)))) + (unless (and focus-lease + (equal (lease-presentation-id focus-lease) presentation-id)) + (setf (presentation-focus-client-id presentation) + (first (presentation-leased-client-ids world presentation))))) + (setf (presentation-dirty-p presentation) t) + (%touch world) + presentation)) + +(defun hide-focused-client-in-presentation (world presentation-id + &key (focus-direction :previous)) + "Hide an active Presentation's focused, actually leased client. + +This focus-addressable wrapper prevents a frontend from accidentally hiding a +parked unavailable slot just because it retained an old focus preference." + (let* ((presentation (%require-active-presentation world presentation-id)) + (client-id (presentation-focus-client-id presentation)) + (lease (and client-id (lease-for-client world client-id)))) + (unless (and client-id lease + (equal (lease-presentation-id lease) presentation-id)) + (error 'invalid-transition + :description "The presentation has no focused visible client to hide.")) + (hide-client-from-presentation world client-id presentation-id + :focus-direction focus-direction))) + +(defun focus-client-on-presentation (world client-id presentation-id) + "Make CLIENT-ID the focus target of an active live Presentation. + +Focus is deliberately model state rather than an X11 side effect: a renderer +may later turn it into an input-focus request, while saving or resuming a View +preserves the user's explicit focus choice. Only a client currently leased to +this Presentation can be selected, so a hidden or cross-Head client cannot +be focused accidentally." + (let ((presentation (find-presentation world presentation-id))) + (unless (presentation-active-p world presentation) + (error 'invalid-transition + :description "Only an active presentation can receive focus.")) + (%ensure-client-in-activity world client-id + (presentation-activity-id presentation)) + (let ((lease (lease-for-client world client-id))) + (unless (and lease + (equal (lease-presentation-id lease) presentation-id)) + (error 'invalid-transition + :description "Focus requires a client leased to this presentation."))) + (unless (equal (presentation-focus-client-id presentation) client-id) + (setf (presentation-focus-client-id presentation) client-id + (presentation-dirty-p presentation) t) + (%touch world)) + presentation)) + +(defun set-presentation-layout-root (world presentation-id layout-root) + "Replace the Head-local tiling tree in an active live draft. + +The tree must describe exactly the Presentation's tiled placements. Floating +clients stay in PLACEMENTS and are intentionally absent from the tree." + (let ((presentation (find-presentation world presentation-id))) + (unless (presentation-active-p world presentation) + (error 'invalid-transition + :description "Only an active presentation can change its layout.")) + (%validate-layout-root world + (presentation-activity-id presentation) + (presentation-placements presentation) + layout-root) + (setf (presentation-layout-root presentation) (%copy-layout-root layout-root) + (presentation-layout-mode presentation) :manual + (presentation-layout-options presentation) nil + (presentation-dirty-p presentation) t) + (%touch world) + presentation)) + +(defun update-view-from-presentation (world view-id presentation-id) + "Explicitly replace VIEW-ID's checkpoint with PRESENTATION-ID's live draft. + +Updating a degraded presentation is rejected rather than silently deleting its +unavailable slots from a reliable checkpoint." + (let ((view (find-view world view-id)) + (presentation (find-presentation world presentation-id))) + (unless (equal (view-activity-id view) + (presentation-activity-id presentation)) + (error 'invalid-transition + :description "A view may only be updated from its own activity.")) + (when (presentation-unavailable-client-ids presentation) + (error 'degraded-presentation-update + :presentation-id presentation-id)) + (setf (view-placements view) (%copy-placements + (presentation-placements presentation)) + (view-layout-root view) (%copy-layout-root + (presentation-layout-root presentation)) + (view-layout-mode view) (presentation-layout-mode presentation) + (view-layout-options view) (copy-tree + (presentation-layout-options presentation)) + (view-focus-client-id view) (presentation-focus-client-id presentation)) + (when (equal (presentation-source-view-id presentation) view-id) + (setf (presentation-dirty-p presentation) nil)) + (%touch world) + view)) + +(defun save-view-from-presentation (world id name presentation-id) + "Create a new View from a non-degraded live presentation." + (let ((presentation (find-presentation world presentation-id))) + (when (presentation-unavailable-client-ids presentation) + (error 'degraded-presentation-update + :presentation-id presentation-id)) + (create-view world id + (presentation-activity-id presentation) + name + (presentation-placements presentation) + :layout-root (presentation-layout-root presentation) + :layout-mode (presentation-layout-mode presentation) + :layout-options (presentation-layout-options presentation) + :focus-client-id (presentation-focus-client-id presentation)))) + +;;;; Invariant checking + +(defun %invalid (format-control &rest arguments) + (error 'invalid-transition :description (apply #'format nil format-control arguments))) + +(defun normalize-activity-arrangements (world &key preferred-presentation-ids) + "Migrate historical draft copies to one current arrangement per Activity/Head. + +Active state wins, then explicit adapter resume history, then newest generated +id. Real leases always win window ownership. Unavailable checkpoint slots are +not live locations. No clients or saved Views are deleted, and no lease moves. +Returns a compact migration report; repeated normalization is a no-op." + (let* ((presentations + (sort (loop for p being the hash-values of (world-presentations world) collect p) + (lambda (a b) + (labels ((rank (p) + (cond ((presentation-active-p world p) 2) + ((member (presentation-id p) preferred-presentation-ids :test #'equal) 1) + (t 0))) + (number (p) + (let ((id (presentation-id p))) + (or (and (stringp id) (ignore-errors (parse-integer id :start 13))) 0)))) + (if (= (rank a) (rank b)) + (if (= (number a) (number b)) + (string< (prin1-to-string (presentation-id a)) (prin1-to-string (presentation-id b))) + (> (number a) (number b))) + (> (rank a) (rank b))))))) + (pairs (%make-id-table)) (owners (%make-id-table)) (sources (%make-id-table)) + (removed nil) (pruned nil) (detached nil)) + (maphash (lambda (id lease) (setf (gethash id owners) (lease-presentation-id lease))) + (world-leases world)) + (dolist (p presentations) + (let* ((id (presentation-id p)) + (key (and (presentation-head-id p) + (list (presentation-activity-id p) (presentation-head-id p))))) + (cond + ((and key (gethash key pairs)) + (remhash id (world-presentations world)) + (push id removed)) + (t + (when key (setf (gethash key pairs) id)) + (dolist (client-id (presentation-client-ids p)) + (let ((owner (gethash client-id owners))) + (if (or (member client-id (presentation-unavailable-client-ids p) :test #'equal) + (and owner (not (equal owner id)))) + (progn (%remove-live-placement world p client-id) + (push (list id client-id) pruned)) + (setf (gethash client-id owners) id)))) + (let ((source (presentation-source-view-id p))) + (when source + (if (gethash source sources) + (progn (setf (presentation-source-view-id p) nil + (presentation-dirty-p p) t) + (push id detached)) + (setf (gethash source sources) id)))))))) + (when (or removed pruned detached) (%touch world)) + (list :retired-arrangements (nreverse removed) :removed-old-locations (nreverse pruned) + :detached-source-labels (nreverse detached)))) + +(defun validate-world (world &key legacy-p) + "Signal INVALID-TRANSITION if WORLD violates a core lease/model invariant. + +Useful both in tests and at the boundary before an eventual X11 executor turns +a planned transition into protocol effects." + (maphash + (lambda (client-id client) + (unless (member (client-shared-p client) '(nil t)) + (%invalid "Client ~S has an invalid sharing flag." client-id)) + (let ((activity (find-activity world (client-activity-id client)))) + (unless (member client-id (activity-client-ids activity) :test #'equal) + (%invalid "Client ~S is absent from its activity's client pool." client-id)))) + (world-clients world)) + (maphash + (lambda (activity-id activity) + (unless (= (length (activity-client-ids activity)) + (length (remove-duplicates (activity-client-ids activity) :test #'equal))) + (%invalid "Activity ~S has duplicate home clients." activity-id)) + (dolist (client-id (activity-client-ids activity)) + (unless (equal activity-id (client-activity-id (find-client world client-id))) + (%invalid "Activity ~S lists a foreign home client ~S." activity-id client-id))) + (let ((seen-names '())) + (dolist (view-id (activity-view-ids activity)) + (let ((name (view-name (find-view world view-id)))) + (when (find name seen-names :test #'equalp) + (%invalid "Activity ~S has duplicate View name ~S." activity-id name)) + (push name seen-names))))) + (world-activities world)) + (maphash + (lambda (view-id view) + (let ((activity (find-activity world (view-activity-id view)))) + (unless (member view-id (activity-view-ids activity) :test #'equal) + (%invalid "View ~S is absent from its activity's view library." view-id)) + (%validate-placements world (view-activity-id view) (view-placements view)) + (%validate-layout-root world + (view-activity-id view) + (view-placements view) + (view-layout-root view)) + (%validate-layout-mode (view-layout-mode view) + (view-layout-options view)))) + (world-views world)) + (maphash + (lambda (viewset-id viewset) + (declare (ignore viewset-id)) + (%validate-viewset-entries world (viewset-entries viewset))) + (world-viewsets world)) + ;; Cached drafts can be resumed or persisted later. Membership transitions + ;; must leave those just as valid as the currently mounted arrangements. + (maphash + (lambda (id presentation) + (declare (ignore id)) + (%validate-placements world (presentation-activity-id presentation) + (presentation-placements presentation)) + (%validate-layout-root world (presentation-activity-id presentation) + (presentation-placements presentation) + (presentation-layout-root presentation))) + (world-presentations world)) + (let ((mounted-views (%make-id-table))) + (maphash + (lambda (head-id head) + (let ((presentation-id (head-active-presentation-id head))) + (when presentation-id + (let ((presentation (find-presentation world presentation-id))) + (unless (equal (presentation-head-id presentation) head-id) + (%invalid "Presentation ~S is mounted on the wrong Head." + presentation-id)) + (%validate-placements world + (presentation-activity-id presentation) + (presentation-placements presentation)) + (%validate-layout-root world + (presentation-activity-id presentation) + (presentation-placements presentation) + (presentation-layout-root presentation)) + (%validate-layout-mode (presentation-layout-mode presentation) + (presentation-layout-options presentation)) + (let ((focus-client-id (presentation-focus-client-id presentation))) + (when focus-client-id + (let ((lease (lease-for-client world focus-client-id))) + (unless (and lease + (equal (lease-presentation-id lease) + presentation-id)) + (%invalid "Active presentation ~S focuses an unleased client ~S." + presentation-id focus-client-id))))) + (let ((view-id (presentation-source-view-id presentation))) + (when view-id + (when (gethash view-id mounted-views) + (%invalid "Named View ~S is mounted on two Heads." view-id)) + (setf (gethash view-id mounted-views) t))))))) + (world-heads world))) + (maphash + (lambda (client-id lease) + (let* ((presentation (find-presentation world + (lease-presentation-id lease)))) + (unless (presentation-active-p world presentation) + (%invalid "Client ~S is leased to an inactive presentation." client-id)) + (unless (client-available-in-activity-p world client-id + (presentation-activity-id presentation)) + (%invalid "Client ~S is leased across activity boundaries." client-id)) + (unless (%placement-for-client (presentation-placements presentation) + client-id) + (%invalid "Client ~S is leased without a placement." client-id)))) + (world-leases world)) + (unless legacy-p + (let ((pairs (%make-id-table)) (locations (%make-id-table)) (sources (%make-id-table))) + (maphash + (lambda (id p) + (when (presentation-source-view-id p) + (let ((source (presentation-source-view-id p))) + (when (gethash source sources) (%invalid "Checkpoint ~S labels multiple working arrangements." source)) + (setf (gethash source sources) id))) + (when (presentation-head-id p) + (let ((pair (list (presentation-activity-id p) (presentation-head-id p)))) + (when (gethash pair pairs) (%invalid "Multiple live arrangements for ~S." pair)) + (setf (gethash pair pairs) id))) + (dolist (client-id (set-difference (presentation-client-ids p) + (presentation-unavailable-client-ids p) :test #'equal)) + (when (gethash client-id locations) + (%invalid "Client ~S has multiple live locations." client-id)) + (setf (gethash client-id locations) id))) + (world-presentations world)))) + t) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..e8083d8 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,256 @@ +(defpackage #:lime.core + (:use #:cl) + (:documentation + "The protocol-independent Activity/View/Head/Lease model used by Lime.") + (:export + ;; Conditions + #:lime-error + #:unknown-entity + #:unknown-entity-kind + #:unknown-entity-id + #:invalid-activity-membership + #:invalid-activity-membership-client-id + #:invalid-activity-membership-activity-id + #:activation-blocked + #:activation-blocked-report + #:stale-transition-plan + #:degraded-presentation-update + #:invalid-transition + + ;; Data types and accessors useful to the UI/backend layer. + #:world + #:make-world + #:normalize-activity-arrangements + #:world-revision + #:activity + #:activity-id + #:activity-name + #:activity-client-ids + #:activity-view-ids + #:client + #:client-id + #:client-activity-id + #:client-shared-p + #:client-available-in-activity-p + #:activity-available-client-ids + #:client-name + #:client-metadata + #:placement + #:make-placement + #:placement-client-id + #:placement-kind + #:placement-data + #:placement-tile-weight + #:default-floating-placement-data + #:layout-leaf + #:make-layout-leaf + #:layout-leaf-client-id + #:layout-split + #:make-layout-split + #:layout-split-orientation + #:layout-split-ratio + #:layout-split-first + #:layout-split-second + #:layout-node-client-ids + #:geometry + #:make-geometry + #:geometry-x + #:geometry-y + #:geometry-width + #:geometry-height + #:default-layout-root + #:master-stack-layout-root + #:resolve-presentation-layout + #:view + #:view-id + #:view-activity-id + #:view-name + #:view-placements + #:view-layout-root + #:view-layout-mode + #:view-layout-options + #:view-focus-client-id + #:viewset-entry + #:make-viewset-entry + #:viewset-entry-head-id + #:viewset-entry-view-id + #:viewset + #:viewset-id + #:viewset-name + #:viewset-entries + #:head + #:head-id + #:head-active-presentation-id + #:presentation + #:presentation-id + #:presentation-head-id + #:presentation-activity-id + #:presentation-source-view-id + #:presentation-placements + #:presentation-layout-root + #:presentation-layout-mode + #:presentation-layout-options + #:presentation-focus-client-id + #:presentation-dirty-p + #:presentation-unavailable-client-ids + #:lease + #:lease-client-id + #:lease-presentation-id + #:activation-conflict + #:activation-conflict-kind + #:activation-conflict-client-id + #:activation-conflict-view-id + #:activation-conflict-holder-head-id + #:activation-conflict-holder-presentation-id + #:activation-report + #:activation-report-world-revision + #:activation-report-head-id + #:activation-report-view-id + #:activation-report-source-presentation-id + #:activation-report-activity-id + #:activation-report-current-presentation-id + #:activation-report-desired-placements + #:activation-report-desired-layout-root + #:activation-report-desired-layout-mode + #:activation-report-desired-layout-options + #:activation-report-focus-client-id + #:activation-report-conflicts + #:activation-plan + #:activation-plan-policy + #:activation-plan-layout-mode + #:activation-plan-layout-options + #:viewset-conflict + #:viewset-conflict-kind + #:viewset-conflict-target-head-id + #:viewset-conflict-client-id + #:viewset-conflict-view-id + #:viewset-conflict-holder-head-id + #:viewset-conflict-holder-presentation-id + #:viewset-report + #:viewset-report-world-revision + #:viewset-report-viewset-id + #:viewset-report-entries + #:viewset-report-outgoing-presentation-ids + #:viewset-report-conflicts + #:viewset-plan + #:viewset-plan-policy + #:viewset-result + #:viewset-result-viewset-id + #:viewset-result-presentation-ids + #:viewset-result-unavailable-client-ids-by-head + #:head-topology-source + #:head-topology-source-head-id + #:head-topology-source-presentation-id + #:head-topology-source-activity-id + #:head-topology-source-source-view-id + #:head-topology-report + #:head-topology-report-world-revision + #:head-topology-report-current-head-ids + #:head-topology-report-desired-head-ids + #:head-topology-report-added-head-ids + #:head-topology-report-retained-head-ids + #:head-topology-report-removed-head-ids + #:head-topology-report-removed-active-sources + #:head-topology-move + #:make-head-topology-move + #:head-topology-move-from-head-id + #:head-topology-move-to-head-id + #:head-topology-plan + #:head-topology-plan-base-revision + #:head-topology-plan-current-head-ids + #:head-topology-plan-desired-head-ids + #:head-topology-plan-added-head-ids + #:head-topology-plan-removed-head-ids + #:head-topology-plan-moves + #:head-topology-result + #:head-topology-result-moved-presentation-ids + #:head-topology-result-suspended-presentation-ids + #:head-topology-result-added-head-ids + #:head-topology-result-removed-head-ids + + ;; Queries. + #:find-activity + #:find-client + #:find-view + #:find-viewset + #:find-head + #:find-presentation + #:list-activities + #:activity-deletion-summary + #:list-viewsets + #:current-presentation + #:activity-draft-for-head + #:lease-for-client + #:presentation-client-ids + #:presentation-leased-client-ids + #:presentation-hidden-client-ids + #:presentation-active-p + #:activation-report-ready-p + #:viewset-report-ready-p + + ;; Model construction. + #:create-head + #:create-activity + #:delete-activity + #:create-client + #:move-client-to-activity + #:move-client-to-presentation + #:set-client-shared + #:make-client-private-in-presentation + #:create-view + #:create-viewset + + ;; Planning and transitions. + #:preflight-view-activation + #:preflight-presentation-resume + #:activity-presentations + #:preflight-presentation-bring + #:bring-presentation-to-head + #:preflight-activity-draft + #:preflight-viewset-activation + #:preflight-head-topology-reconciliation + #:build-strict-activation-plan + #:build-partial-activation-plan + #:build-taking-activation-plan + #:commit-activation-plan + #:build-strict-viewset-plan + #:build-partial-viewset-plan + #:build-taking-viewset-plan + #:commit-viewset-plan + #:build-head-topology-reconciliation-plan + #:commit-head-topology-reconciliation-plan + #:activate-view-strictly + #:activate-view-partially + #:activate-view-taking + #:activate-viewset-strictly + #:activate-viewset-partially + #:activate-viewset-taking + #:resume-presentation-strictly + #:resume-presentation-partially + #:resume-presentation-taking + #:open-activity-draft + #:retire-client + #:transfer-client-lease + #:reclaim-available-slots + #:show-client-on-presentation + #:hide-client-from-presentation + #:hide-focused-client-in-presentation + #:focus-client-on-presentation + #:set-presentation-layout-root + #:set-presentation-layout-mode + #:set-presentation-master-stack-layout + #:set-presentation-monocle-layout + #:set-presentation-manual-layout + #:set-client-tile-weight + #:set-focused-layout-split-orientation + #:adjust-focused-layout-split-ratio + #:swap-presentation-layout-clients + #:swap-focused-layout-client + #:promote-client-to-master + #:presentation-client-floating-p + #:toggle-client-floating + #:toggle-focused-client-floating + #:set-client-floating-geometry + #:update-view-from-presentation + #:save-view-from-presentation + #:validate-world)) diff --git a/src/persistence/model.lisp b/src/persistence/model.lisp new file mode 100644 index 0000000..d011da6 --- /dev/null +++ b/src/persistence/model.lisp @@ -0,0 +1,246 @@ +(in-package #:lime.persistence) + +;;;; Versioned plain data, independent of X11, disk I/O, and Lisp object layouts. + +(defun check-data (data) + "Accept only bounded, acyclic data. Never serialize functions or live objects." + (let ((path (make-hash-table :test #'eq)) (remaining 200000) + (stack (list (list data 0 nil)))) + ;; Explicit traversal keeps a broad untrusted list off the Lisp call stack. + (loop while stack do + (destructuring-bind (value depth exit-p) (pop stack) + (if exit-p + (remhash value path) + (progn + (when (or (minusp (decf remaining)) (> depth 128)) + (error "Session data exceeds its size/depth limit.")) + (typecase value + (cons + (when (gethash value path) (error "Circular session data.")) + (setf (gethash value path) t) + (push (list value depth t) stack) + (push (list (cdr value) depth nil) stack) + (push (list (car value) (1+ depth) nil) stack)) + (null nil) + (string (when (> (length value) 32768) (error "Session string is too long."))) + (symbol (unless (or (eq value t) (keywordp value)) + (error "Unsupported session symbol ~S." value))) + (rational (when (> (max (integer-length (numerator value)) + (integer-length (denominator value))) 256) + (error "Session number is too large."))) + (float (unless (<= (- most-positive-double-float) value most-positive-double-float) + (error "Session number must be finite."))) + (otherwise (error "Unsupported session value of type ~S." (type-of value))))))))) + data) + +(defun copy-data (data) + "Freeze data for a worker, including mutable strings (COPY-TREE alone doesn't)." + (check-data data) + (labels ((clone (value) + (cond + ((stringp value) (copy-seq value)) + ((consp value) + (let* ((result (cons nil nil)) (tail result) (source value)) + (loop + (setf (car tail) (clone (car source))) + (if (consp (cdr source)) + (setf (cdr tail) (cons nil nil) tail (cdr tail) source (cdr source)) + (progn (setf (cdr tail) (clone (cdr source))) (return result)))))) + (t value)))) + (clone data))) + +(defun check-record (data keys) + "Require an exact, non-duplicated keyword schema (also rejects dotted lists)." + (unless (and (listp data) (evenp (list-length data)) + (= (length data) (* 2 (length keys))) + (equal (sort (loop for tail on data by #'cddr collect (car tail)) + #'string< :key #'symbol-name) + (sort (copy-list keys) #'string< :key #'symbol-name))) + (error "Malformed session record; expected fields ~S." keys)) + data) + +(defun %id (value &optional nullable) + (unless (or (and nullable (null value)) + (and (stringp value) (plusp (length value))) + (and value (keywordp value)) (integerp value)) + (error "Invalid session identifier ~S." value)) + value) + +(defun %name (value) + (unless (stringp value) (error "Session names must be strings.")) value) + +(defun %boolean (value) + (unless (member value '(t nil)) (error "Invalid session boolean ~S." value)) value) + +(defun %rows (table function) + (mapcar (lambda (id) (funcall function (gethash id table))) + (sort (loop for id being the hash-keys of table collect id) + #'string< :key #'prin1-to-string))) + +(defun %tree-data (node) + (etypecase node + (null nil) + (layout-leaf (list :leaf (layout-leaf-client-id node))) + (layout-split (list :split (layout-split-orientation node) (layout-split-ratio node) + (%tree-data (layout-split-first node)) + (%tree-data (layout-split-second node)))))) + +(defun %restore-tree (data) + (cond ((null data) nil) + ((and (listp data) (eq (first data) :leaf) (= 2 (length data))) + (make-layout-leaf :client-id (%id (second data)))) + ((and (listp data) (eq (first data) :split) (= 5 (length data))) + (make-layout-split :orientation (second data) :ratio (third data) + :first (%restore-tree (fourth data)) :second (%restore-tree (fifth data)))) + (t (error "Malformed saved layout tree.")))) + +(defun %placement-data (placements) + (mapcar (lambda (placement) + (list :client (placement-client-id placement) :kind (placement-kind placement) + :data (copy-tree (check-data (placement-data placement))))) placements)) + +(defun %restore-placements (data) + (mapcar (lambda (row) + (check-record row '(:client :kind :data)) + (make-placement :client-id (%id (getf row :client)) :kind (getf row :kind) + :data (copy-tree (getf row :data)))) data)) + +(defun snapshot-world (world) + "Capture model data, not leases, X resources, configuration, or executable code." + (validate-world world) + (copy-data + (list :format :lime-world :version 3 :revision (world-revision world) + :next-presentation-number (lime.core::world-next-presentation-number world) + :activities (%rows (lime.core::world-activities world) + (lambda (a) (list :id (activity-id a) :name (activity-name a) + :clients (copy-list (activity-client-ids a)) + :views (copy-list (activity-view-ids a))))) + :clients (%rows (lime.core::world-clients world) + (lambda (c) (list :id (client-id c) :activity (client-activity-id c) + :name (client-name c) :shared (client-shared-p c) + :metadata (copy-tree (check-data (client-metadata c)))))) + :views (%rows (lime.core::world-views world) + (lambda (v) (list :id (view-id v) :activity (view-activity-id v) :name (view-name v) + :placements (%placement-data (view-placements v)) + :tree (%tree-data (view-layout-root v)) :layout (view-layout-mode v) + :options (copy-tree (view-layout-options v)) :focus (view-focus-client-id v)))) + :viewsets (%rows (lime.core::world-viewsets world) + (lambda (v) (list :id (viewset-id v) :name (viewset-name v) + :entries (mapcar (lambda (e) (list (viewset-entry-head-id e) + (viewset-entry-view-id e))) + (viewset-entries v))))) + :heads (%rows (lime.core::world-heads world) + (lambda (h) (list :id (head-id h) :active (head-active-presentation-id h)))) + :presentations + (%rows (lime.core::world-presentations world) + (lambda (p) (list :id (presentation-id p) :head (presentation-head-id p) + :activity (presentation-activity-id p) :source (presentation-source-view-id p) + :placements (%placement-data (presentation-placements p)) + :tree (%tree-data (presentation-layout-root p)) :layout (presentation-layout-mode p) + :options (copy-tree (presentation-layout-options p)) + :focus (presentation-focus-client-id p) :dirty (presentation-dirty-p p) + :unavailable (copy-list (presentation-unavailable-client-ids p)))))))) + +(defun %distinct-subset (ids all) + (and (listp ids) (= (length ids) (length (remove-duplicates ids :test #'equal))) + (every (lambda (id) (member id all :test #'equal)) ids))) + +(defun restore-world (data &key (normalize-arrangements-p t)) + "Build and validate a fresh candidate. Never mutate the live world on failure." + (check-data data) + (check-record data '(:format :version :revision :next-presentation-number :activities :clients + :views :viewsets :heads :presentations)) + (unless (and (eq :lime-world (getf data :format)) (member (getf data :version) '(1 2 3))) + (error "Unsupported Lime world format/version.")) + (dolist (key '(:revision :next-presentation-number)) + (unless (typep (getf data key) '(integer 0 *)) (error "Invalid session counter ~S." key))) + (let ((world (make-world))) + (dolist (row (getf data :activities)) + (check-record row '(:id :name :clients :views)) + (create-activity world (%id (getf row :id)) (%name (getf row :name)))) + (dolist (row (getf data :clients)) + (check-record row (if (eql 1 (getf data :version)) + '(:id :activity :name :metadata) + '(:id :activity :name :metadata :shared))) + (unless (or (null (getf row :name)) (stringp (getf row :name))) + (error "Invalid saved client name.")) + (create-client world (%id (getf row :id)) (%id (getf row :activity)) + :name (getf row :name) :metadata (copy-tree (getf row :metadata)) + :shared-p (%boolean (getf row :shared)))) + (dolist (row (getf data :views)) + (check-record row '(:id :activity :name :placements :tree :layout :options :focus)) + (create-view world (%id (getf row :id)) (%id (getf row :activity)) (%name (getf row :name)) + (%restore-placements (getf row :placements)) + :layout-root (%restore-tree (getf row :tree)) :layout-mode (getf row :layout) + :layout-options (getf row :options) :focus-client-id (%id (getf row :focus) t))) + ;; Preserve Activity pool/library order while rejecting missing/foreign ids. + (dolist (row (getf data :activities)) + (let ((activity (find-activity world (getf row :id)))) + (dolist (pair (list (cons :clients (activity-client-ids activity)) + (cons :views (activity-view-ids activity)))) + (unless (and (%distinct-subset (getf row (car pair)) (cdr pair)) + (= (length (getf row (car pair))) (length (cdr pair)))) + (error "Invalid saved Activity membership."))) + (setf (activity-client-ids activity) (copy-list (getf row :clients)) + (activity-view-ids activity) (copy-list (getf row :views))))) + (dolist (row (getf data :viewsets)) + (check-record row '(:id :name :entries)) + (create-viewset world (%id (getf row :id)) (%name (getf row :name)) + (mapcar (lambda (e) + (unless (= 2 (length e)) (error "Malformed Viewset entry.")) + (make-viewset-entry :head-id (%id (first e)) :view-id (%id (second e)))) + (getf row :entries)))) + (dolist (row (getf data :heads)) + (check-record row '(:id :active)) + (setf (head-active-presentation-id (create-head world (%id (getf row :id)))) + (%id (getf row :active) t))) + (dolist (row (getf data :presentations)) + (check-record row '(:id :head :activity :source :placements :tree :layout :options :focus :dirty :unavailable)) + (let* ((id (%id (getf row :id))) (activity (%id (getf row :activity))) + (placements (%restore-placements (getf row :placements))) + (tree (%restore-tree (getf row :tree))) (source (%id (getf row :source) t)) + (focus (%id (getf row :focus) t)) (unavailable (getf row :unavailable))) + (lime.core::%ensure-fresh-id (lime.core::world-presentations world) id :presentation) + (find-activity world activity) + (lime.core::%validate-placements world activity placements) + (lime.core::%validate-layout-root world activity placements tree) + (lime.core::%validate-layout-mode (getf row :layout) (getf row :options)) + (when (and source (not (equal activity (view-activity-id (find-view world source))))) + (error "Presentation references a View from another Activity.")) + (when (and focus (not (find focus placements :key #'placement-client-id :test #'equal))) + (error "Presentation focus has no placement.")) + (unless (%distinct-subset unavailable (mapcar #'placement-client-id placements)) + (error "Invalid unavailable-client list.")) + (setf (gethash id (lime.core::world-presentations world)) + (lime.core::make-presentation + :id id :head-id (%id (getf row :head) t) :activity-id activity :source-view-id source + :placements placements :layout-root tree :layout-mode (getf row :layout) + :layout-options (copy-tree (getf row :options)) :focus-client-id focus + :dirty-p (%boolean (getf row :dirty)) :unavailable-client-ids (copy-list unavailable))))) + ;; Leases are derived, not deserialized authority. Conflicting grants fail. + (maphash (lambda (id head) + (declare (ignore id)) + (when (head-active-presentation-id head) + (let ((p (find-presentation world (head-active-presentation-id head)))) + (dolist (client (set-difference (presentation-client-ids p) + (presentation-unavailable-client-ids p) :test #'equal)) + (when (lease-for-client world client) (error "Saved Heads request duplicate leases.")) + (setf (gethash client (lime.core::world-leases world)) + (lime.core::make-lease :client-id client :presentation-id (presentation-id p))))))) + (lime.core::world-heads world)) + (setf (lime.core::world-next-presentation-number world) (getf data :next-presentation-number) + (lime.core::world-revision world) (getf data :revision)) + ;; Protect future generated ids even for snapshots edited by hand. + (maphash (lambda (id p) + (declare (ignore p)) + (when (and (stringp id) (uiop:string-prefix-p "presentation-" id)) + (let ((number (ignore-errors (parse-integer id :start 13)))) + (when number + (setf (lime.core::world-next-presentation-number world) + (max number (lime.core::world-next-presentation-number world))))))) + (lime.core::world-presentations world)) + (validate-world world :legacy-p (< (getf data :version) 3)) + (when (and normalize-arrangements-p (< (getf data :version) 3)) + (normalize-activity-arrangements world) + (validate-world world)) + world)) diff --git a/src/persistence/package.lisp b/src/persistence/package.lisp new file mode 100644 index 0000000..89b6e26 --- /dev/null +++ b/src/persistence/package.lisp @@ -0,0 +1,6 @@ +(defpackage #:lime.persistence + (:use #:cl #:lime.core) + (:export #:snapshot-world #:restore-world #:check-data #:copy-data #:check-record + #:session-store #:open-session-store #:close-session-store + #:session-store-path #:read-session-store #:write-session-store + #:default-session-path)) diff --git a/src/persistence/store.lisp b/src/persistence/store.lisp new file mode 100644 index 0000000..2a7161a --- /dev/null +++ b/src/persistence/store.lisp @@ -0,0 +1,122 @@ +(in-package #:lime.persistence) + +;;;; Linux storage boundary: one lifetime writer lock, private temp + fsync + +;;;; atomic rename. The previous file is untouched until a complete write wins. + +(defstruct (session-store (:constructor %make-session-store)) path descriptor) + +(defun default-session-path (display-name) + "Separate actual/nested X displays without depending on a Lime environment variable." + (merge-pathnames + (format nil "lime/sessions/display-~A.sexp" + (with-output-to-string (out) + (loop for c across (or display-name "default") + do (if (or (alphanumericp c) (find c ".-")) + (write-char c out) (format out "_~2,'0X" (char-code c)))))) + (uiop:ensure-directory-pathname + (or (let ((path (uiop:getenv "XDG_STATE_HOME"))) + (and path (plusp (length path)) path)) + (merge-pathnames ".local/state/" (user-homedir-pathname)))))) + +(defun %private-file (path) + (unless (zerop (cffi:foreign-funcall "chmod" :string (namestring path) :unsigned-int #o600 :int)) + (error "Cannot make session file private: ~A" path))) + +(defun open-session-store (path) + "Claim one writer for PATH; another Lime using it must not overwrite this desk." + (let* ((path (merge-pathnames (pathname path) (uiop:getcwd))) + (lock (pathname (concatenate 'string (namestring path) ".lock")))) + (when (or (wild-pathname-p path) (null (pathname-name path))) + (error "Session path must name one file without wildcards.")) + (ensure-directories-exist path) + ;; O_RDWR | O_CREAT | O_CLOEXEC, Linux. Lock files are kept: unlinking a + ;; held lock would let two different inodes each claim the same path. + (let ((fd (cffi:foreign-funcall "open" :string (namestring lock) + :int (logior 2 #o100 #o2000000) :unsigned-int #o600 :int))) + (when (minusp fd) (error "Cannot open session lock: ~A" lock)) + (handler-case + (progn + (%private-file lock) + (unless (zerop (cffi:foreign-funcall "flock" :int fd :int (logior 2 4) :int)) + (error "Session file is already owned by another Lime: ~A" path)) + (%make-session-store :path path :descriptor fd)) + (error (c) + (cffi:foreign-funcall "close" :int fd :int) + (error c)))))) + +(defun close-session-store (store) + (when (session-store-descriptor store) + (cffi:foreign-funcall "close" :int (session-store-descriptor store) :int) + (setf (session-store-descriptor store) nil)) + store) + +(defun %require-open-store (store) + (unless (session-store-descriptor store) (error "Session store is closed."))) + +(defun %sync-path (path) + (let ((fd (cffi:foreign-funcall "open" :string (namestring path) :int #o2000000 :int))) + (when (minusp fd) (error "Cannot open session path for synchronization: ~A" path)) + (unwind-protect + (unless (zerop (cffi:foreign-funcall "fsync" :int fd :int)) + (error "Cannot synchronize session path: ~A" path)) + (cffi:foreign-funcall "close" :int fd :int)))) + +(defun write-session-store (store data) + "Write validated plain data privately and atomically; never LOAD/EVAL state." + (%require-open-store store) + (check-data data) + (let* ((path (session-store-path store)) (directory (uiop:pathname-directory-pathname path)) + ;; PRINT-READABLY may emit implementation-specific #A forms for + ;; base strings. We preserve text, not string storage specialization. + (text (let ((*print-readably* nil) (*print-escape* t) (*print-pretty* nil) (*print-circle* nil) + (*print-base* 10) (*print-radix* nil) (*print-case* :upcase) + (*read-default-float-format* 'single-float) + (*print-level* nil) (*print-length* nil) (*package* (find-package :cl-user))) + (write-to-string data)))) + (when (> (length text) (* 4 1024 1024)) (error "Session snapshot exceeds 4 MiB text limit.")) + (when (>= (length (babel:string-to-octets text :encoding :utf-8)) (* 8 1024 1024)) + (error "Session snapshot exceeds 8 MiB encoded limit.")) + (%check-reader-depth text) + (uiop:with-temporary-file (:stream stream :pathname temporary :directory directory + :prefix ".lime-session-" :external-format :utf-8) + (%private-file temporary) + (write-line text stream) + :close-stream + (%sync-path temporary) + (unless (zerop (cffi:foreign-funcall "rename" :string (namestring temporary) + :string (namestring path) :int)) + (error "Cannot atomically replace session file: ~A" path)) + (%sync-path directory))) + data) + +(defun %check-reader-depth (text) + ;; Bound nesting before invoking the Lisp reader, including malformed input. + ;; No reader dispatch, comments, or quote syntax are needed in this format. + (let ((depth 0) (string-p nil) (escaped nil)) + (loop for c across text do + (cond (escaped (setf escaped nil)) + ((and string-p (char= c #\\)) (setf escaped t)) + ((char= c #\") (setf string-p (not string-p))) + (string-p nil) + ((find c "#;'`,|\\") (error "Reader syntax is not allowed in session data.")) + ((char= c #\() (when (> (incf depth) 128) (error "Session nesting is too deep."))) + ((char= c #\)) (when (minusp (decf depth)) (error "Unbalanced session data."))))) + (when (or string-p escaped (not (zerop depth))) (error "Truncated session data.")))) + +(defun read-session-store (store) + "Read one bounded data form. Missing is NIL; malformed/unsupported input signals." + (%require-open-store store) + (let ((path (session-store-path store))) + (when (probe-file path) + (with-open-file (stream path :element-type '(unsigned-byte 8)) + (when (> (file-length stream) (* 8 1024 1024)) (error "Session file exceeds 8 MiB."))) + (let ((text (uiop:read-file-string path :external-format :utf-8))) + (%check-reader-depth text) + (let ((*read-eval* nil) (*read-base* 10) (*read-default-float-format* 'single-float) + (*readtable* (copy-readtable nil)) + (*package* (find-package :cl-user))) + (with-input-from-string (stream text) + (let* ((eof (gensym)) (data (read stream nil eof))) + (when (eq data eof) (error "Session file is empty.")) + (unless (eq eof (read stream nil eof)) (error "Session file contains trailing data.")) + (check-data data)))))))) diff --git a/src/presentation-navigation.lisp b/src/presentation-navigation.lisp new file mode 100644 index 0000000..6f7e66b --- /dev/null +++ b/src/presentation-navigation.lisp @@ -0,0 +1,77 @@ +(in-package #:lime.core) + +;;;; Moving a live arrangement is distinct from recalling a saved checkpoint. +;;;; This layer has no navigation preferences, renderer, or physical geometry. + +(defun activity-presentations (world activity-id) + (find-activity world activity-id) + (sort (loop for p being the hash-values of (world-presentations world) + when (equal activity-id (presentation-activity-id p)) collect p) + #'string< :key (lambda (p) (princ-to-string (presentation-id p))))) + +(defun preflight-presentation-bring (world head-id presentation-id) + "Inspect moving/resuming an arrangement, ignoring its own existing leases. +Missing slots from partial checkpoint recalls are not requests to steal windows." + (let* ((p (find-presentation world presentation-id)) (copy (copy-presentation p))) + (dolist (id (presentation-unavailable-client-ids p)) (%remove-client-from-container copy id)) + (let ((report (%preflight-activation world head-id (presentation-activity-id p) + (presentation-source-view-id p) presentation-id + (presentation-placements copy) (presentation-layout-root copy) + (presentation-layout-mode p) (presentation-layout-options p) + (presentation-focus-client-id copy)))) + (setf (activation-report-conflicts report) + (remove-if (lambda (conflict) + (equal presentation-id (activation-conflict-holder-presentation-id conflict))) + (activation-report-conflicts report))) + report))) + +(defun bring-presentation-to-head (world presentation-id head-id &key expected-revision) + "Bring the current arrangement HERE; swap if it is already displayed elsewhere. + +An active swap preserves Presentation identities and lease objects. Inactive +arrangements of the displaced Activity transpose between the same two Heads, +so swapping a portion of an extended Activity cannot overwrite its other part. +An inactive incoming arrangement simply resumes here; no other Head changes. +No checkpoint is recalled, no hidden client is shown, and no View is modified." + (when (and expected-revision (/= expected-revision (world-revision world))) + (error 'stale-transition-plan)) + (let* ((p (find-presentation world presentation-id)) + (target (find-head world head-id)) + (outgoing (current-presentation world head-id)) + (from (presentation-head-id p)) + (active-p (presentation-active-p world p))) + (when (eq p outgoing) (return-from bring-presentation-to-head p)) + (validate-world world) + (let ((report (preflight-presentation-bring world head-id presentation-id))) + (unless (activation-report-ready-p report) (error 'activation-blocked :report report)) + (let* ((activities (remove-duplicates + (cons (presentation-activity-id p) + (when (and active-p outgoing) (list (presentation-activity-id outgoing)))) + :test #'equal)) + (moves (loop for other being the hash-values of (world-presentations world) + when (member (presentation-activity-id other) activities :test #'equal) + append + (cond + ((eq other p) (list (cons other head-id))) + ((equal head-id (presentation-head-id other)) (list (cons other from))) + ((and from (equal from (presentation-head-id other))) (list (cons other head-id))))))) + ;; Everything that can reject the transition has been checked above. + (if active-p + (setf (head-active-presentation-id (find-head world from)) + (and outgoing (presentation-id outgoing))) + (when outgoing (%release-presentation-leases world outgoing))) + (dolist (move moves) (setf (presentation-head-id (car move)) (cdr move))) + (setf (head-active-presentation-id target) presentation-id) + (unless active-p + ;; Same return semantics as a Head-local resume: stale missing slots + ;; disappear from the working arrangement, never from the checkpoint. + (setf (presentation-placements p) (%copy-placements (activation-report-desired-placements report)) + (presentation-layout-root p) (%copy-layout-root (activation-report-desired-layout-root report)) + (presentation-unavailable-client-ids p) nil + (presentation-focus-client-id p) + (%focus-from-grants (presentation-focus-client-id p) (presentation-client-ids p))) + (%claim-live-locations world p (presentation-client-ids p)) + (dolist (id (presentation-client-ids p)) + (setf (gethash id (world-leases world)) (make-lease :client-id id :presentation-id presentation-id)))) + (%touch world) + p)))) diff --git a/src/topology.lisp b/src/topology.lisp new file mode 100644 index 0000000..a30ed79 --- /dev/null +++ b/src/topology.lisp @@ -0,0 +1,211 @@ +(in-package #:lime.core) + +;;;; Explicit Head-topology reconciliation +;;; +;;; Physical output discovery belongs to an adapter, but deciding what becomes +;;; of a live task when a Head disappears is model policy. This module keeps +;;; that decision inspectable and explicit: an outgoing Presentation either +;;; moves intact to one chosen destination or becomes an unbound cached draft. + +(defun %world-head-ids (world) + (let (head-ids) + (maphash (lambda (head-id head) + (declare (ignore head)) + (push head-id head-ids)) + (world-heads world)) + head-ids)) + +(defun %require-distinct-head-ids (head-ids description) + (unless (and (listp head-ids) head-ids + (every #'identity head-ids) + (= (length head-ids) + (length (remove-duplicates head-ids :test #'equal)))) + (error 'invalid-transition :description description)) + head-ids) + +(defun %topology-active-source (world head-id) + (let ((presentation (current-presentation world head-id))) + (when presentation + (make-head-topology-source + :head-id head-id + :presentation-id (presentation-id presentation) + :activity-id (presentation-activity-id presentation) + :source-view-id (presentation-source-view-id presentation))))) + +(defun preflight-head-topology-reconciliation (world desired-head-ids) + "Compare WORLD's logical Heads with DESIRED-HEAD-IDS without mutating state. + +Adapters supply only durable logical identifiers here, never pixels or X11 +objects. Every removed Head that currently has a Presentation appears in +REMOVED-ACTIVE-SOURCES; a frontend or command caller can move it explicitly or +leave it unmentioned to suspend its draft and release its window leases." + (%require-distinct-head-ids + desired-head-ids + "A Head topology needs at least one distinct, non-NIL Head id.") + (let* ((current-head-ids (%world-head-ids world)) + (retained-head-ids + (remove-if-not (lambda (head-id) + (member head-id desired-head-ids :test #'equal)) + current-head-ids)) + (added-head-ids + (remove-if (lambda (head-id) + (member head-id current-head-ids :test #'equal)) + desired-head-ids)) + (removed-head-ids + (remove-if (lambda (head-id) + (member head-id desired-head-ids :test #'equal)) + current-head-ids))) + (make-head-topology-report + :world-revision (world-revision world) + :current-head-ids (copy-list current-head-ids) + :desired-head-ids (copy-list desired-head-ids) + :added-head-ids added-head-ids + :retained-head-ids retained-head-ids + :removed-head-ids removed-head-ids + :removed-active-sources + (remove nil (mapcar (lambda (head-id) + (%topology-active-source world head-id)) + removed-head-ids))))) + +(defun %require-head-topology-moves (report moves) + (unless (every (lambda (move) (typep move 'head-topology-move)) moves) + (error 'invalid-transition + :description "Topology moves must be HEAD-TOPOLOGY-MOVE structures.")) + (let ((source-head-ids (mapcar #'head-topology-move-from-head-id moves)) + (destination-head-ids (mapcar #'head-topology-move-to-head-id moves)) + (removable-head-ids + (mapcar #'head-topology-source-head-id + (head-topology-report-removed-active-sources report)))) + (unless (= (length source-head-ids) + (length (remove-duplicates source-head-ids :test #'equal))) + (error 'invalid-transition + :description "A removed Head's Presentation can move only once.")) + (unless (= (length destination-head-ids) + (length (remove-duplicates destination-head-ids :test #'equal))) + (error 'invalid-transition + :description "Only one Presentation can be active on a destination Head.")) + (dolist (move moves) + (unless (member (head-topology-move-from-head-id move) + removable-head-ids :test #'equal) + (error 'invalid-transition + :description "A topology move must originate from a removed Head with an active Presentation.")) + (unless (member (head-topology-move-to-head-id move) + (head-topology-report-desired-head-ids report) :test #'equal) + (error 'invalid-transition + :description "A topology move needs a destination in the desired Head set.")))) + moves) + +(defun build-head-topology-reconciliation-plan (report &key moves) + "Build an explicit topology plan from a read-only REPORT. + +Each HEAD-TOPOLOGY-MOVE names a removed source Head and a desired destination +Head. Omitted removed sources are deliberately suspended rather than guessed: +their drafts survive unbound, their leases are released, and they can later be +resumed onto an explicitly chosen Head. Added Heads without an incoming move +remain blank." + (unless (typep report 'head-topology-report) + (error 'invalid-transition + :description "Topology reconciliation needs a HEAD-TOPOLOGY-REPORT.")) + (%require-head-topology-moves report moves) + (make-head-topology-plan + :base-revision (head-topology-report-world-revision report) + :current-head-ids (copy-list (head-topology-report-current-head-ids report)) + :desired-head-ids (copy-list (head-topology-report-desired-head-ids report)) + :added-head-ids (copy-list (head-topology-report-added-head-ids report)) + :removed-head-ids (copy-list (head-topology-report-removed-head-ids report)) + :moves (mapcar (lambda (move) + (make-head-topology-move + :from-head-id (head-topology-move-from-head-id move) + :to-head-id (head-topology-move-to-head-id move))) + moves))) + +(defun %assert-head-topology-plan-current (world plan) + (unless (= (head-topology-plan-base-revision plan) (world-revision world)) + (error 'stale-transition-plan)) + (unless (%same-id-set-p (%world-head-ids world) + (head-topology-plan-current-head-ids plan)) + (error 'stale-transition-plan))) + +(defun %release-and-suspend-presentation (world head) + (let ((presentation-id (head-active-presentation-id head))) + (when presentation-id + (let ((presentation (find-presentation world presentation-id))) + (%release-presentation-leases world presentation) + (setf (head-active-presentation-id head) nil + (presentation-head-id presentation) nil) + presentation)))) + +(defun %release-destination-presentation (world head) + (let ((presentation-id (head-active-presentation-id head))) + (when presentation-id + (let ((presentation (find-presentation world presentation-id))) + (%release-presentation-leases world presentation) + (setf (head-active-presentation-id head) nil) + presentation)))) + +(defun commit-head-topology-reconciliation-plan (world plan) + "Commit PLAN atomically at the pure-model boundary. + +Incoming Presentations retain their exact draft, focus, and leases. An active +destination Presentation is merely cached on its surviving Head after its +leases are released. Unmoved removed Heads become unbound cached drafts, so +no window stays invisibly leased to an unplugged monitor." + (unless (typep plan 'head-topology-plan) + (error 'invalid-transition + :description "Topology reconciliation needs a HEAD-TOPOLOGY-PLAN.")) + (%assert-head-topology-plan-current world plan) + (let* ((moves (head-topology-plan-moves plan)) + (move-source-ids (mapcar #'head-topology-move-from-head-id moves)) + (move-sources + (mapcar (lambda (move) + (let* ((source-head + (find-head world + (head-topology-move-from-head-id move))) + (presentation-id + (head-active-presentation-id source-head))) + (unless presentation-id + (error 'stale-transition-plan)) + (cons move (find-presentation world presentation-id)))) + moves)) + (suspended-presentation-ids '()) + (moved-presentation-ids '())) + ;; Add logical Heads before routing an incoming Presentation to one. + (dolist (head-id (head-topology-plan-added-head-ids plan)) + (setf (gethash head-id (world-heads world)) (make-head :id head-id))) + ;; A retained destination gives up only its own active leases. Its cached + ;; draft remains attached to that physical Head and can be resumed later. + (dolist (move moves) + (%release-destination-presentation + world (find-head world (head-topology-move-to-head-id move)))) + ;; Removed sources either transfer whole or become unbound, lease-free + ;; drafts. The former release no leases: ownership follows the same + ;; Presentation object to its chosen destination. + (dolist (head-id (head-topology-plan-removed-head-ids plan)) + (let ((head (find-head world head-id))) + (if (member head-id move-source-ids :test #'equal) + (setf (head-active-presentation-id head) nil) + (let ((suspended (%release-and-suspend-presentation world head))) + (when suspended + (push (presentation-id suspended) suspended-presentation-ids)))))) + (dolist (entry move-sources) + (let* ((move (car entry)) + (presentation (cdr entry)) + (destination-head + (find-head world (head-topology-move-to-head-id move)))) + (let ((displaced (activity-draft-for-head world (presentation-activity-id presentation) + (head-topology-move-to-head-id move)))) + (when (and displaced (not (eq displaced presentation))) + (setf (presentation-head-id displaced) nil))) + (setf (presentation-head-id presentation) + (head-topology-move-to-head-id move) + (head-active-presentation-id destination-head) + (presentation-id presentation)) + (push (presentation-id presentation) moved-presentation-ids))) + (dolist (head-id (head-topology-plan-removed-head-ids plan)) + (remhash head-id (world-heads world))) + (%touch world) + (make-head-topology-result + :moved-presentation-ids (nreverse moved-presentation-ids) + :suspended-presentation-ids (nreverse suspended-presentation-ids) + :added-head-ids (copy-list (head-topology-plan-added-head-ids plan)) + :removed-head-ids (copy-list (head-topology-plan-removed-head-ids plan))))) diff --git a/src/ui/package.lisp b/src/ui/package.lisp new file mode 100644 index 0000000..195e812 --- /dev/null +++ b/src/ui/package.lisp @@ -0,0 +1,48 @@ +(defpackage #:lime.ui + (:use #:cl) + (:documentation + "Renderer-neutral command-palette state for Lime frontends.") + (:export + #:ui-candidate + #:make-ui-candidate + #:ui-candidate-id + #:ui-candidate-label + #:ui-candidate-detail + #:ui-candidate-key-hint + #:ui-candidate-action + #:ui-key-node + #:make-ui-key-node + #:ui-key-node-id + #:ui-key-node-key + #:ui-key-node-label + #:ui-key-node-detail + #:ui-key-node-action + #:ui-key-node-children + #:ui-result + #:make-ui-result + #:ui-result-kind + #:ui-result-candidates + #:ui-result-message + #:ui-result-prompt + #:ui-result-initial-value + #:ui-result-submit-action + #:ui-close-result + #:ui-replace-result + #:ui-keep-open-result + #:ui-prompt-result + #:ui-session + #:make-ui-session + #:ui-session-mode + #:ui-session-query + #:ui-session-candidates + #:ui-session-key-root + #:ui-session-key-nodes + #:ui-session-key-path + #:ui-session-key-page + #:ui-session-selected-index + #:ui-session-status + #:ui-session-prompt + #:ui-session-selected-candidate + #:ui-session-apply-result + #:ui-session-activate-candidate + #:ui-session-handle-key)) diff --git a/src/ui/session.lisp b/src/ui/session.lisp new file mode 100644 index 0000000..fc0302e --- /dev/null +++ b/src/ui/session.lisp @@ -0,0 +1,365 @@ +(in-package #:lime.ui) + +;;;; Renderer-neutral palette session +;;; +;;; This is intentionally not an X11 widget. A frontend supplies candidate +;;; actions, turns the current session into pixels, and forwards normalized +;;; keys here. The same model can later power a bar popup, an IPC picker, or a +;;; graphical Viewset selector without teaching the Lime core about UI state. + +(defstruct ui-candidate + "One searchable palette choice supplied by a frontend catalog. + +ACTION is a zero-argument function that returns a UI-RESULT. It may close over +an adapter command surface, but this data type itself has no X11 dependency." + id + label + detail + key-hint + action) + +(defstruct ui-key-node + "One key-labelled entry in a renderer-neutral command tree. + +KEY is a character recognized while its parent menu is visible. A node may +have CHILDREN to enter another menu, or an ACTION that returns a UI-RESULT. +The node itself contains no X11, model, or command-layer policy." + id + key + label + detail + action + (children '())) + +(defstruct ui-result + "A frontend action's requested palette transition. + +KIND is :CLOSE, :REPLACE, :KEEP-OPEN, or :PROMPT. REPLACE supplies the next +candidate set, which is how a View activation can turn into an explicit +collision-choice menu without special-casing that workflow in the palette +engine. PROMPT supplies a label and a string-submit action for the same +renderer-neutral minibuffer interaction." + kind + candidates + message + prompt + initial-value + submit-action) + +(defun ui-close-result (&optional message) + (make-ui-result :kind :close :message message)) + +(defun ui-replace-result (candidates &optional message) + (make-ui-result :kind :replace :candidates candidates :message message)) + +(defun ui-keep-open-result (&optional message) + (make-ui-result :kind :keep-open :message message)) + +(defun ui-prompt-result (prompt submit-action &key initial-value message) + "Ask the frontend to collect one non-empty string before SUBMIT-ACTION runs. + +PROMPT is display text and SUBMIT-ACTION receives the entered string. It must +return another UI-RESULT, allowing a prompt to close, replace itself with a +choice list, or request another prompt without the renderer learning any +workflow semantics." + (make-ui-result :kind :prompt + :prompt prompt + :initial-value initial-value + :submit-action submit-action + :message message)) + +(defstruct (ui-session (:constructor %make-ui-session)) + root-candidates + all-candidates + (mode :search) + (query "") + (candidates '()) + (selected-index 0) + prompt + submit-action + (key-root '()) + (key-nodes '()) + (key-path '()) + (key-page 0) + (status "Type to filter; Enter to run; Esc to cancel.")) + +(defun %searchable-text (candidate) + (format nil "~A ~A ~A" + (or (ui-candidate-label candidate) "") + (or (ui-candidate-detail candidate) "") + (or (ui-candidate-key-hint candidate) ""))) + +(defun %fuzzy-match-score (query text) + "Return a lower-is-better fuzzy score for QUERY in TEXT, or NIL. + +An ordinary contiguous substring is preferred. Otherwise every query +character must appear in order, which makes compact dmenu-style input such as +\"wmprj\" useful without turning search into a hard-to-predict scorer." + (let* ((needle (string-downcase query)) + (haystack (string-downcase text)) + (substring-position (search needle haystack))) + (cond + ((zerop (length needle)) 0) + (substring-position substring-position) + (t + (let ((next-position 0) + (first-position nil) + (gaps 0)) + (loop for character across needle + for found-position = (position character haystack + :start next-position) + do (unless found-position + (return-from %fuzzy-match-score nil)) + (unless first-position + (setf first-position found-position)) + (incf gaps (- found-position next-position)) + (setf next-position (1+ found-position))) + ;; Keep a contiguous early match ahead of sparse matches, while + ;; retaining a deterministic order for ties in %REFRESH-CANDIDATES. + (+ 100 (* 10 gaps) (or first-position 0))))))) + +(defun %candidate-match-score (candidate query) + (%fuzzy-match-score query (%searchable-text candidate))) + +(defun %refresh-candidates (session) + (let ((query (ui-session-query session))) + (setf (ui-session-candidates session) + (if (zerop (length query)) + (copy-list (ui-session-all-candidates session)) + (mapcar #'second + (stable-sort + (loop for candidate in (ui-session-all-candidates session) + for score = (%candidate-match-score candidate query) + when score collect (list score candidate)) + #'< :key #'first))) + (ui-session-selected-index session) 0)) + session) + +(defun make-ui-session (candidates &key status key-path (mode :search)) + "Start a :SEARCH picker or :KEY-PATH command map, without running any action. + +The root catalog survives temporary pickers (Views, collisions, etc.), so +returning to the command map and then searching means all commands again." + (let ((session (%refresh-candidates + (%make-ui-session :root-candidates (copy-list candidates) + :all-candidates (copy-list candidates) + :key-root (copy-list key-path))))) + (ecase mode + (:search nil) + (:key-path (%switch-to-key-path session))) + (when status (setf (ui-session-status session) status)) + session)) + +(defun ui-session-selected-candidate (session) + (nth (ui-session-selected-index session) (ui-session-candidates session))) + +(defun %move-selection (session delta) + (let ((count (length (ui-session-candidates session)))) + (when (plusp count) + (setf (ui-session-selected-index session) + (mod (+ (ui-session-selected-index session) delta) count)))) + session) + +(defun %apply-result (session result) + (unless (typep result 'ui-result) + (error "A palette candidate action must return a UI-RESULT, got ~S." result)) + (when (ui-result-message result) + (setf (ui-session-status session) (ui-result-message result))) + (ecase (ui-result-kind result) + ((:close :keep-open) nil) + (:replace + (setf (ui-session-mode session) :search + (ui-session-prompt session) nil + (ui-session-submit-action session) nil + (ui-session-all-candidates session) (copy-list (ui-result-candidates result)) + (ui-session-status session) + (or (ui-result-message result) "Type to filter; Enter to choose; Esc to cancel.") + (ui-session-query session) "") + (%refresh-candidates session)) + (:prompt + (unless (and (stringp (ui-result-prompt result)) + (functionp (ui-result-submit-action result))) + (error "A UI prompt result needs a string label and a submit function.")) + (setf (ui-session-mode session) :prompt + (ui-session-prompt session) (ui-result-prompt result) + (ui-session-submit-action session) (ui-result-submit-action result) + (ui-session-status session) + (or (ui-result-message result) "Enter to confirm; Esc to cancel.") + (ui-session-query session) (or (ui-result-initial-value result) "") + (ui-session-candidates session) '() + (ui-session-selected-index session) 0))) + result) + +(defun ui-session-apply-result (session result) + "Apply a declarative UI RESULT to SESSION and return RESULT. + +Frontends normally receive a result from UI-SESSION-HANDLE-KEY. This public +entry point also lets a frontend begin directly in a prompt or a replacement +choice list without pretending the user pressed an initial key." + (%apply-result session result)) + +(defun %switch-to-search (session) + (setf (ui-session-mode session) :search + (ui-session-all-candidates session) (copy-list (ui-session-root-candidates session)) + (ui-session-prompt session) nil + (ui-session-submit-action session) nil + (ui-session-key-nodes session) '() + (ui-session-key-path session) '() + (ui-session-key-page session) 0 + (ui-session-query session) "" + (ui-session-status session) "Type to filter; Enter to run; Tab for menu; Esc to cancel.") + (%refresh-candidates session) + (ui-keep-open-result)) + +(defun %key-path-description (session) + (if (null (ui-session-key-path session)) + "root" + (format nil "~{~A~^ > ~}" + (mapcar #'ui-key-node-label (ui-session-key-path session))))) + +(defun %switch-to-key-path (session) + (if (null (ui-session-key-root session)) + (%apply-result session + (ui-keep-open-result "No key-path commands are configured.")) + (progn + (setf (ui-session-mode session) :key-path + (ui-session-prompt session) nil + (ui-session-submit-action session) nil + (ui-session-key-nodes session) (ui-session-key-root session) + (ui-session-key-path session) '() + (ui-session-key-page session) 0 + (ui-session-query session) "" + (ui-session-candidates session) '() + (ui-session-selected-index session) 0 + (ui-session-status session) + "Tab search; Backspace up; Esc close.") + (ui-keep-open-result)))) + +(defun %key-node-for-key (session key) + (find key (ui-session-key-nodes session) + :key #'ui-key-node-key :test #'char-equal)) + +(defun %enter-key-node (session node) + (cond + ((ui-key-node-children node) + (setf (ui-session-key-path session) + (append (ui-session-key-path session) (list node)) + (ui-session-key-nodes session) (ui-key-node-children node) + (ui-session-key-page session) 0 + (ui-session-status session) + "Tab search; Backspace up; Esc close.") + (ui-keep-open-result)) + ((ui-key-node-action node) + (%apply-result session (funcall (ui-key-node-action node)))) + (t + (%apply-result session + (ui-keep-open-result "That key has no action yet."))))) + +(defun %handle-key-path-character (session key) + (let ((node (%key-node-for-key session key))) + (cond + (node (%enter-key-node session node)) + ((char= key #\Space) (%switch-to-search session)) + (t (%apply-result + session + (ui-keep-open-result + (format nil "~C is not available in ~A." + key (%key-path-description session)))))))) + +(defun %key-path-up (session) + (let ((path (ui-session-key-path session))) + (when path + (let ((parent-path (butlast path))) + (setf (ui-session-key-path session) parent-path + (ui-session-key-page session) 0 + (ui-session-key-nodes session) + (if parent-path + (ui-key-node-children (car (last parent-path))) + (ui-session-key-root session))) + (setf (ui-session-status session) + "Tab search; Backspace up; Esc close."))) + (ui-keep-open-result))) + +(defun %blank-string-p (string) + (zerop (length (string-trim '(#\Space #\Tab #\Newline #\Return) string)))) + +(defun %handle-prompt-return (session) + (let ((input (ui-session-query session))) + (if (%blank-string-p input) + (%apply-result session (ui-keep-open-result "Input is required.")) + (%apply-result session + (funcall (ui-session-submit-action session) input))))) + +(defun ui-session-activate-candidate (session candidate) + "Activate a displayed CANDIDATE with the same transition as keyboard Return. + +Use the actual candidate object, not an index into an old filtered list. A +stale hit from a previous picker or query must never run a different command." + (let ((index (and (eq (ui-session-mode session) :search) + (position candidate (ui-session-candidates session) :test #'eq)))) + (if index + (progn + (setf (ui-session-selected-index session) index) + (%apply-result session (funcall (ui-candidate-action candidate)))) + (ui-keep-open-result)))) + +(defun ui-session-handle-key (session key) + "Update SESSION for normalized KEY and return its requested UI-RESULT. + +KEY is a character or :UP, :DOWN, :RETURN, :BACKSPACE, :TAB, :ESCAPE, +:PAGE-UP, or :PAGE-DOWN. In search mode characters filter locally and candidate +actions run on :RETURN. In prompt mode they edit the entered string and +:RETURN invokes the prompt submit action. In key-path mode characters select +the visible command tree. Every action returns a declarative result for the +frontend to realize." + (case key + (:escape (ui-close-result)) + ((:page-up :page-down) + (when (eq (ui-session-mode session) :key-path) + ;; The renderer clamps this viewport request to its measured page count. + (setf (ui-session-key-page session) + (max 0 (+ (ui-session-key-page session) (if (eq key :page-up) -1 1))))) + (ui-keep-open-result)) + (:tab + (ecase (ui-session-mode session) + (:search (%switch-to-key-path session)) + (:key-path (%switch-to-search session)) + (:prompt (%apply-result session + (ui-keep-open-result "Finish or cancel this prompt first."))))) + (:up (progn (when (eq (ui-session-mode session) :search) + (%move-selection session -1)) + (ui-keep-open-result))) + (:down (progn (when (eq (ui-session-mode session) :search) + (%move-selection session 1)) + (ui-keep-open-result))) + (:backspace + (if (eq (ui-session-mode session) :key-path) + (%key-path-up session) + (let ((query (ui-session-query session))) + (when (plusp (length query)) + (setf (ui-session-query session) (subseq query 0 (1- (length query)))) + (when (eq (ui-session-mode session) :search) + (%refresh-candidates session))) + (ui-keep-open-result)))) + (:return + (ecase (ui-session-mode session) + (:prompt (%handle-prompt-return session)) + (:key-path (%apply-result session + (ui-keep-open-result "Choose one of the shown keys."))) + (:search + (let ((candidate (ui-session-selected-candidate session))) + (if candidate + (ui-session-activate-candidate session candidate) + (%apply-result session + (ui-keep-open-result "No matching command."))))))) + (otherwise + (when (and (characterp key) (graphic-char-p key)) + (if (eq (ui-session-mode session) :key-path) + (return-from ui-session-handle-key + (%handle-key-path-character session key)) + (progn + (setf (ui-session-query session) + (concatenate 'string (ui-session-query session) (string key))) + (when (eq (ui-session-mode session) :search) + (%refresh-candidates session))))) + (ui-keep-open-result)))) diff --git a/src/viewset.lisp b/src/viewset.lisp new file mode 100644 index 0000000..e52079f --- /dev/null +++ b/src/viewset.lisp @@ -0,0 +1,335 @@ +(in-package #:lime.core) + +;;;; Atomic multi-Head Viewset activation +;;; +;;; A View remains the useful one-Head checkpoint. A Viewset is only a named +;;; selection of several such checkpoints. Its planner deliberately looks at +;;; all selected Heads as one replacement group: that is what makes a genuine +;;; left/right View swap safe without transient duplicate-View or duplicate- +;;; Lease fiction. + +(defun viewset-report-ready-p (report) + "Return true when REPORT needs no policy choice or repair." + (null (viewset-report-conflicts report))) + +(defun %viewset-conflicts-of-kind (report kind) + (remove-if-not (lambda (conflict) + (eq (viewset-conflict-kind conflict) kind)) + (viewset-report-conflicts report))) + +(defun %viewset-entry-head-ids (entries) + (mapcar #'viewset-entry-head-id entries)) + +(defun %viewset-outgoing-presentation-ids (world entries) + (mapcar (lambda (entry) + (let ((head-id (viewset-entry-head-id entry))) + (cons head-id + (head-active-presentation-id (find-head world head-id))))) + entries)) + +(defun %viewset-outgoing-presentation-id-p (presentation-id outgoing-ids) + (member presentation-id (mapcar #'cdr outgoing-ids) :test #'equal)) + +(defun %viewset-conflict (kind entry &key client-id view-id holder) + (make-viewset-conflict + :kind kind + :target-head-id (viewset-entry-head-id entry) + :client-id client-id + :view-id view-id + :holder-head-id (and holder (presentation-head-id holder)) + :holder-presentation-id (and holder (presentation-id holder)))) + +(defun preflight-viewset-activation (world viewset-id) + "Inspect VIEWSET-ID across every selected Head without changing WORLD. + +Each target Head's current Presentation is part of the same outgoing group. +Its leases and mounted View are therefore harmless to another incoming entry +in this Viewset: commit will release all of them before granting any incoming +lease. A lease or mounted View on an unselected Head remains a real conflict. +Two Viewset entries requesting the same real client are deliberately reported +as an unresolvable internal conflict rather than receiving arbitrary order. +" + (let* ((viewset (find-viewset world viewset-id)) + (entries (%copy-viewset-entries (viewset-entries viewset))) + ;; FIND-HEAD validates every saved logical Head before any caller can + ;; act on a partial report. + (outgoing-presentation-ids + (%viewset-outgoing-presentation-ids world entries)) + (target-head-ids (%viewset-entry-head-ids entries)) + (conflicts '()) + (requested-client-heads (make-hash-table :test #'equal))) + (dolist (entry entries) + (let* ((view-id (viewset-entry-view-id entry)) + (view (find-view world view-id))) + ;; A named View currently mounted on another selected Head is fine: + ;; that holder is itself being replaced by this same atomic commit. + (dolist (presentation (%active-presentations world)) + (when (and (equal (presentation-source-view-id presentation) view-id) + (not (member (presentation-head-id presentation) + target-head-ids :test #'equal))) + (push (%viewset-conflict :view-mounted entry + :view-id view-id :holder presentation) + conflicts))) + (dolist (placement (view-placements view)) + (let* ((client-id (placement-client-id placement)) + (first-target-head-id + (gethash client-id requested-client-heads))) + (if first-target-head-id + ;; The first request is enough context to make the definition + ;; repairable; a second demand cannot be resolved by :PARTIAL + ;; or :TAKE without silently picking a winner. + (push (make-viewset-conflict + :kind :client-requested + :target-head-id (viewset-entry-head-id entry) + :client-id client-id + :holder-head-id first-target-head-id) + conflicts) + (setf (gethash client-id requested-client-heads) + (viewset-entry-head-id entry))) + (let ((lease (lease-for-client world client-id))) + (when (and lease + (not (%viewset-outgoing-presentation-id-p + (lease-presentation-id lease) + outgoing-presentation-ids))) + (push (%viewset-conflict + :client-leased entry :client-id client-id + :holder (find-presentation world + (lease-presentation-id lease))) + conflicts))))))) + (make-viewset-report + :world-revision (world-revision world) + :viewset-id viewset-id + :entries entries + :outgoing-presentation-ids outgoing-presentation-ids + :conflicts (nreverse conflicts)))) + +(defun %require-viewset-resolvable-conflicts (report) + "Reject conflicts that policy cannot responsibly resolve automatically." + (when (remove-if (lambda (conflict) + (eq (viewset-conflict-kind conflict) :client-leased)) + (viewset-report-conflicts report)) + (error 'activation-blocked :report report))) + +(defun %viewset-unavailable-by-head (report) + "Return deterministic partial-activation omissions in Viewset entry order." + (mapcar + (lambda (entry) + (cons (viewset-entry-head-id entry) + (loop for conflict in (viewset-report-conflicts report) + when (and (eq (viewset-conflict-kind conflict) :client-leased) + (equal (viewset-conflict-target-head-id conflict) + (viewset-entry-head-id entry))) + collect (viewset-conflict-client-id conflict)))) + (viewset-report-entries report))) + +(defun %make-viewset-plan (report policy unavailable-by-head take-client-ids) + (make-viewset-plan + :base-revision (viewset-report-world-revision report) + :viewset-id (viewset-report-viewset-id report) + :policy policy + :entries (%copy-viewset-entries (viewset-report-entries report)) + :outgoing-presentation-ids (copy-tree + (viewset-report-outgoing-presentation-ids report)) + :unavailable-client-ids-by-head (copy-tree unavailable-by-head) + :take-client-ids (copy-list take-client-ids))) + +(defun build-strict-viewset-plan (report) + "Build a Viewset plan only when every requested client and View is free." + (unless (typep report 'viewset-report) + (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT.")) + (unless (viewset-report-ready-p report) + (error 'activation-blocked :report report)) + (%make-viewset-plan report :strict '() '())) + +(defun build-partial-viewset-plan (report) + "Build a Viewset plan that omits only clients leased outside its target group." + (unless (typep report 'viewset-report) + (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT.")) + (%require-viewset-resolvable-conflicts report) + (%make-viewset-plan report :partial (%viewset-unavailable-by-head report) '())) + +(defun build-taking-viewset-plan (report) + "Build a Viewset plan that explicitly takes outside client leases together." + (unless (typep report 'viewset-report) + (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT.")) + (%require-viewset-resolvable-conflicts report) + (%make-viewset-plan + report :take '() + (remove-duplicates + (mapcar #'viewset-conflict-client-id + (%viewset-conflicts-of-kind report :client-leased)) + :test #'equal))) + +(defun %viewset-plan-unavailable-client-ids (plan head-id) + (copy-list (cdr (assoc head-id + (viewset-plan-unavailable-client-ids-by-head plan) + :test #'equal)))) + +(defun %assert-viewset-plan-current (world plan) + (unless (= (viewset-plan-base-revision plan) (world-revision world)) + (error 'stale-transition-plan)) + (let ((viewset (find-viewset world (viewset-plan-viewset-id plan)))) + ;; A normal CREATE-VIEWSET revision check catches mutation. This direct + ;; shape check also protects callers constructing a plan by hand. + (unless (equal (mapcar (lambda (entry) + (list (viewset-entry-head-id entry) + (viewset-entry-view-id entry))) + (viewset-entries viewset)) + (mapcar (lambda (entry) + (list (viewset-entry-head-id entry) + (viewset-entry-view-id entry))) + (viewset-plan-entries plan))) + (error 'stale-transition-plan))) + (dolist (entry (viewset-plan-entries plan)) + (let* ((head-id (viewset-entry-head-id entry)) + (head (find-head world head-id)) + (expected (cdr (assoc head-id + (viewset-plan-outgoing-presentation-ids plan) + :test #'equal)))) + (unless (equal (head-active-presentation-id head) expected) + (error 'stale-transition-plan))))) + +(defun %validate-viewset-plan (world plan) + (unless (member (viewset-plan-policy plan) '(:strict :partial :take)) + (error 'invalid-transition + :description "A Viewset plan policy must be :STRICT, :PARTIAL, or :TAKE.")) + (%validate-viewset-entries world (viewset-plan-entries plan)) + ;; Reuse the read-only collision logic at commit time. A legitimate plan is + ;; fresh by revision, so this is primarily a defense against hand-built + ;; inconsistent plans at the public core boundary. + (let ((report (preflight-viewset-activation world (viewset-plan-viewset-id plan)))) + (ecase (viewset-plan-policy plan) + (:strict + (unless (viewset-report-ready-p report) + (error 'activation-blocked :report report)) + (unless (and (null (viewset-plan-unavailable-client-ids-by-head plan)) + (null (viewset-plan-take-client-ids plan))) + (error 'invalid-transition + :description "A strict Viewset plan may not omit or take clients."))) + (:partial + (%require-viewset-resolvable-conflicts report) + (unless (equal (viewset-plan-unavailable-client-ids-by-head plan) + (%viewset-unavailable-by-head report)) + (error 'invalid-transition + :description "A partial Viewset plan does not match its preflight omissions."))) + (:take + (%require-viewset-resolvable-conflicts report) + (let ((expected-takes + (remove-duplicates + (mapcar #'viewset-conflict-client-id + (%viewset-conflicts-of-kind report :client-leased)) + :test #'equal))) + (unless (and (equal (sort (copy-list (viewset-plan-take-client-ids plan)) + #'string< :key #'princ-to-string) + (sort (copy-list expected-takes) + #'string< :key #'princ-to-string)) + (null (viewset-plan-unavailable-client-ids-by-head plan))) + (error 'invalid-transition + :description "A taking Viewset plan does not match its preflight leases.")))))) + (dolist (entry (viewset-plan-entries plan)) + (let* ((head-id (viewset-entry-head-id entry)) + (view (find-view world (viewset-entry-view-id entry))) + (unavailable-client-ids + (%viewset-plan-unavailable-client-ids plan head-id))) + (dolist (client-id unavailable-client-ids) + (unless (%placement-for-client (view-placements view) client-id) + (error 'invalid-transition + :description "A Viewset plan omits an unplaced client.")))))) + +(defun %release-viewset-outgoing-presentations (world plan) + (dolist (entry (viewset-plan-entries plan)) + (let* ((head-id (viewset-entry-head-id entry)) + (head (find-head world head-id)) + (presentation-id (head-active-presentation-id head))) + (when presentation-id + (%release-presentation-leases world (find-presentation world presentation-id)) + (setf (head-active-presentation-id head) nil))))) + +(defun %install-viewset-entry (world entry unavailable-client-ids) + "Mount ENTRY as a fresh Presentation after all outgoing leases are released." + (let* ((head-id (viewset-entry-head-id entry)) + (head (find-head world head-id)) + (view (find-view world (viewset-entry-view-id entry))) + (grant-client-ids + (remove-if (lambda (client-id) + (member client-id unavailable-client-ids :test #'equal)) + (%placement-client-ids (view-placements view)))) + (presentation (or (activity-draft-for-head world (view-activity-id view) head-id) + (make-presentation :id (%fresh-presentation-id world))))) + (setf (presentation-head-id presentation) head-id + (presentation-activity-id presentation) (view-activity-id view) + (presentation-source-view-id presentation) (view-id view) + (presentation-placements presentation) (%copy-placements (view-placements view)) + (presentation-layout-root presentation) (%copy-layout-root (view-layout-root view)) + (presentation-layout-mode presentation) (view-layout-mode view) + (presentation-layout-options presentation) (copy-tree (view-layout-options view)) + (presentation-focus-client-id presentation) + (%focus-from-grants (view-focus-client-id view) grant-client-ids) + (presentation-dirty-p presentation) (not (null unavailable-client-ids)) + (presentation-unavailable-client-ids presentation) + (copy-list unavailable-client-ids)) + (setf (gethash (presentation-id presentation) (world-presentations world)) presentation + (head-active-presentation-id head) (presentation-id presentation)) + (%claim-live-locations world presentation grant-client-ids) + (dolist (client-id grant-client-ids) + ;; Internal duplicate requests and foreign leases were ruled out before + ;; we started mutation. Keep this hard guard for model callers anyway. + (when (lease-for-client world client-id) + (error 'invalid-transition + :description "Viewset activation would give a client two leases.")) + (setf (gethash client-id (world-leases world)) + (make-lease :client-id client-id + :presentation-id (presentation-id presentation)))) + presentation)) + +(defun commit-viewset-plan (world plan) + "Commit PLAN as one atomic whole-desk Viewset transition. + +All target Heads release their outgoing leases before any incoming View mounts. +That ordering is the semantic point of Viewsets: legitimate swaps do not need +temporary duplicate View exceptions, and a failed preflight has made no model +or X11 change." + (unless (typep plan 'viewset-plan) + (error 'invalid-transition :description "Viewset activation needs a VIEWSET-PLAN.")) + (%assert-viewset-plan-current world plan) + (%validate-viewset-plan world plan) + (%release-viewset-outgoing-presentations world plan) + ;; Only :TAKE has outside incumbent leases left at this point. It explicitly + ;; degrades those live drafts without touching their saved Views. + (when (eq (viewset-plan-policy plan) :take) + (dolist (client-id (viewset-plan-take-client-ids plan)) + (%transfer-away-from-incumbent world client-id))) + (let ((presentation-ids '()) + (unavailable-by-head '())) + (dolist (entry (viewset-plan-entries plan)) + (let* ((head-id (viewset-entry-head-id entry)) + (unavailable-client-ids + (%viewset-plan-unavailable-client-ids plan head-id)) + (presentation + (%install-viewset-entry world entry unavailable-client-ids))) + (push (cons head-id (presentation-id presentation)) presentation-ids) + (when unavailable-client-ids + (push (cons head-id unavailable-client-ids) unavailable-by-head)))) + (%touch world) + (make-viewset-result + :viewset-id (viewset-plan-viewset-id plan) + :presentation-ids (nreverse presentation-ids) + :unavailable-client-ids-by-head (nreverse unavailable-by-head)))) + +(defun activate-viewset-strictly (world viewset-id) + "Activate VIEWSET-ID only when every selected Head can mount completely." + (commit-viewset-plan world + (build-strict-viewset-plan + (preflight-viewset-activation world viewset-id)))) + +(defun activate-viewset-partially (world viewset-id) + "Activate VIEWSET-ID without taking clients leased outside its target Heads." + (commit-viewset-plan world + (build-partial-viewset-plan + (preflight-viewset-activation world viewset-id)))) + +(defun activate-viewset-taking (world viewset-id) + "Activate VIEWSET-ID and explicitly transfer outside client leases." + (commit-viewset-plan world + (build-taking-viewset-plan + (preflight-viewset-activation world viewset-id)))) diff --git a/src/x11/activity-navigation-ui.lisp b/src/x11/activity-navigation-ui.lisp new file mode 100644 index 0000000..d8f4a9d --- /dev/null +++ b/src/x11/activity-navigation-ui.lisp @@ -0,0 +1,63 @@ +(in-package #:lime.x11) + +;;;; Explicit footprint commands use the ordinary dropdown, not a second UI. + +(defun %ui-activity-monitor-context (backend) + (let* ((head (x11-backend-focused-head-id backend)) + (p (%current-presentation-or-error backend head))) + (list :head head :presentation (presentation-id p) :activity (presentation-activity-id p) + :revision (world-revision (x11-backend-world backend))))) + +(defun %ui-activity-monitor-context-valid-p (backend context) + (let ((p (current-presentation (x11-backend-world backend) (getf context :head)))) + (and (equal (getf context :head) (x11-backend-focused-head-id backend)) p + (equal (getf context :presentation) (presentation-id p)) + (= (getf context :revision) (world-revision (x11-backend-world backend)))))) + +(defun %ui-extend-activity-result (backend) + (let* ((context (%ui-activity-monitor-context backend)) + (activity (getf context :activity)) + (heads (remove (getf context :head) (backend-head-ids backend) :test #'equal))) + (if (null heads) (ui-keep-open-result "There is no other monitor to extend onto.") + (ui-replace-result + (cons (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" + :action (lambda () (ui-close-result))) + (loop for head in heads collect + (let ((target head)) + (make-ui-candidate + :id (list :extend-activity activity target) + :label (format nil "Extend ~A onto ~A" (activity-name (find-activity (x11-backend-world backend) activity)) target) + :detail "open its portion there; leave this monitor and its windows in place" + :key-hint "Enter" + :action (lambda () + (if (not (%ui-activity-monitor-context-valid-p backend context)) + (ui-keep-open-result "The desk changed. Cancel and choose the monitor again.") + (progn + (backend-extend-activity-to-head backend activity target + :expected-revision (getf context :revision)) + (ui-close-result "Activity extended; move or show windows on its new portion.")))))))) + "Choose a monitor. This explicitly enables independent portions; it does not duplicate or gather windows.")))) + +(defun %ui-portable-activity-result (backend) + (let* ((context (%ui-activity-monitor-context backend)) + (activity (getf context :activity))) + (ui-replace-result + (list (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" :action (lambda () (ui-close-result))) + (make-ui-candidate + :id (list :portable-activity activity) :label "Use this arrangement on one monitor" :key-hint "Enter" + :detail "other portions must be empty and inactive; hidden windows and saved Views are kept" + :action (lambda () + (if (not (%ui-activity-monitor-context-valid-p backend context)) + (ui-keep-open-result "The desk changed. Cancel and review the Activity again.") + (progn + (backend-make-activity-portable backend activity (getf context :head) + :expected-revision (getf context :revision)) + (ui-close-result "Activity is portable; selecting it elsewhere brings it there.")))))) + "Make this Activity portable? Empty portions lose their checkpoint labels, but no saved View or window is deleted."))) + +(defun %ui-activity-monitor-candidates (backend) + (when (current-presentation (x11-backend-world backend) (x11-backend-focused-head-id backend)) + (list (make-ui-candidate :id :extend-activity :label "Extend Activity to another monitor..." :key-hint "Enter" + :action (lambda () (%ui-extend-activity-result backend))) + (make-ui-candidate :id :portable-activity :label "Use Activity on one monitor..." :key-hint "Enter" + :action (lambda () (%ui-portable-activity-result backend)))))) diff --git a/src/x11/activity-navigation.lisp b/src/x11/activity-navigation.lisp new file mode 100644 index 0000000..7e271b8 --- /dev/null +++ b/src/x11/activity-navigation.lisp @@ -0,0 +1,149 @@ +(in-package #:lime.x11) + +;;;; Portable versus deliberately extended navigation is adapter policy, not +;;;; another kind of Activity or View. The core only moves actual arrangements. +;;;; A sidecar keeps this persistent policy independent of backend struct layout. + +(defstruct activity-navigation-state world (rows nil) (generation 0) observed-revision) +(defvar *backend-activity-navigation-states* (make-hash-table :test #'eq #+sbcl :weakness #+sbcl :key)) + +(defun %forget-activity-navigation-state (backend) + (remhash backend *backend-activity-navigation-states*)) + +(defun %arrangement-substantive-p (p) + ;; An empty saved checkpoint is still intentional, unlike an old empty draft. + (or (presentation-placements p) (presentation-source-view-id p))) + +(defun %infer-activity-navigation-row (world activity-id) + "Conservative one-time migration. Never move/delete any existing arrangement." + (let* ((parts (activity-presentations world activity-id)) + (substantive (remove-if-not #'%arrangement-substantive-p parts)) + (active (remove-if-not (lambda (p) (presentation-active-p world p)) parts))) + (if (or (rest substantive) (and (null substantive) (rest active))) + (list activity-id :extended nil) + (list activity-id :portable + (let ((p (or (first substantive) (first active) (first parts)))) + (and p (presentation-id p))))))) + +(defun %activity-navigation-state (backend) + (let* ((world (x11-backend-world backend)) + (state (gethash backend *backend-activity-navigation-states*))) + (unless (and state (eq world (activity-navigation-state-world state))) + (setf state (make-activity-navigation-state :world world) + (gethash backend *backend-activity-navigation-states*) state)) + (unless (eql (world-revision world) (activity-navigation-state-observed-revision state)) + (let ((rows + (loop for a in (list-activities world) for id = (activity-id a) + for existing = (assoc id (activity-navigation-state-rows state) :test #'equal) + collect + (cond + ((null existing) (%infer-activity-navigation-row world id)) + ((eq :extended (second existing)) existing) + (t + (let* ((parts (activity-presentations world id)) + (primary (find (third existing) parts :key #'presentation-id :test #'equal)) + (others (remove primary parts))) + (cond + ((null primary) (%infer-activity-navigation-row world id)) + ;; Explicit checkpoint/window placement on another + ;; Head may also extend the Activity. Never auto-fold + ;; it again when clients close or become hidden. + ((some (lambda (p) (and (%arrangement-substantive-p p) + (or (%arrangement-substantive-p primary) + (presentation-active-p world p)))) others) + (list id :extended nil)) + (t existing)))))))) + (unless (equal rows (activity-navigation-state-rows state)) + (incf (activity-navigation-state-generation state)) + (setf (activity-navigation-state-rows state) rows)) + (setf (activity-navigation-state-observed-revision state) (world-revision world)))) + state)) + +(defun %activity-navigation-row (backend activity-id) + (find-activity (x11-backend-world backend) activity-id) + (assoc activity-id (activity-navigation-state-rows (%activity-navigation-state backend)) :test #'equal)) + +(defun backend-activity-navigation-mode (backend activity-id) + "Return :PORTABLE or :EXTENDED. Window closure never resets an explicit span." + (second (%activity-navigation-row backend activity-id))) + +(defun %portable-activity-presentation (backend activity-id) + (let* ((row (%activity-navigation-row backend activity-id)) (id (third row))) + (when (and (eq :portable (second row)) id) (find-presentation (x11-backend-world backend) id)))) + +(defun %set-activity-navigation (backend activity-id mode presentation-id) + (let ((state (%activity-navigation-state backend))) + (setf (activity-navigation-state-rows state) + (cons (list activity-id mode presentation-id) + (remove activity-id (activity-navigation-state-rows state) :key #'first :test #'equal))) + (incf (activity-navigation-state-generation state))) + mode) + +(defun %activity-navigation-snapshot (backend) + (lime.persistence:copy-data (activity-navigation-state-rows (%activity-navigation-state backend)))) + +(defun %activity-navigation-read-data (data world) + (lime.persistence:check-data data) + (let ((seen nil)) + (dolist (row data) + (unless (and (listp row) (= 3 (length row)) (member (second row) '(:portable :extended))) + (error "Invalid activity navigation row.")) + (destructuring-bind (id mode primary) row + (find-activity world id) + (when (member id seen :test #'equal) (error "Duplicate activity navigation policy.")) + (push id seen) + (when (and (eq mode :extended) primary) (error "Extended Activity cannot have one primary arrangement.")) + (when primary + (unless (equal id (presentation-activity-id (find-presentation world primary))) + (error "Portable arrangement belongs to another Activity."))))) + (unless (= (length seen) (length (list-activities world))) + (error "Activity navigation policies must cover every Activity."))) + (make-activity-navigation-state :world world :rows (copy-tree data))) + +(defun %portable-view-preview-world (backend view-id head-id) + "Preview the portable move on a detached model before offering lease choices. +No live rearrangement happens merely because the user opened a conflict menu." + (let* ((world (x11-backend-world backend)) (view (find-view world view-id)) + (p (%portable-activity-presentation backend (view-activity-id view)))) + (when (and p (not (eq p (current-presentation world head-id)))) + (let ((copy (lime.persistence:restore-world (lime.persistence:snapshot-world world)))) + (bring-presentation-to-head copy (presentation-id p) head-id) + copy)))) + +(defun backend-extend-activity-to-head + (backend activity-id head-id &key expected-revision) + "Explicitly open/resume a separate portion here; do not summon any windows." + (%head-for-id backend head-id) + (let ((world (x11-backend-world backend))) + (find-activity world activity-id) + (when (and expected-revision (/= expected-revision (world-revision world))) (error 'stale-transition-plan)) + ;; Check before recording intent: a failed extension is not a mode change. + (let ((report (preflight-activity-draft world head-id activity-id :default-layout (configured-default-layout backend)))) + (unless (activation-report-ready-p report) (error 'activation-blocked :report report))) + (let ((p (open-activity-draft world head-id activity-id :default-layout (configured-default-layout backend)))) + (%set-activity-navigation backend activity-id :extended nil) + (%apply-command-result backend p)))) + +(defun backend-make-activity-portable (backend activity-id head-id &key expected-revision) + "Keep this portion as the portable arrangement; never silently gather others. +Other portions must be empty and inactive. Saved checkpoints remain untouched." + (%head-for-id backend head-id) + (let* ((world (x11-backend-world backend)) + (p (activity-draft-for-head world activity-id head-id))) + (find-activity world activity-id) + (when (and expected-revision (/= expected-revision (world-revision world))) (error 'stale-transition-plan)) + (unless p (error 'invalid-transition :description "Open the Activity here before making it portable.")) + (when (some (lambda (other) (and (not (eq p other)) + (or (presentation-placements other) (presentation-active-p world other)))) + (activity-presentations world activity-id)) + (error 'invalid-transition + :description "Other portions still contain windows or are displayed. Move/hide their windows and switch those monitors away first.")) + ;; Empty historical portions no longer claim checkpoint source labels, but + ;; their saved View definitions (including empty Views) remain unchanged. + (dolist (other (activity-presentations world activity-id)) + (when (and (not (eq p other)) (presentation-source-view-id other)) + (setf (presentation-source-view-id other) nil (presentation-dirty-p other) t) + (lime.core::%touch world))) + (%set-activity-navigation backend activity-id :portable (presentation-id p)) + (when (x11-backend-display backend) (render-head-bars backend)) + p)) diff --git a/src/x11/appearance.lisp b/src/x11/appearance.lisp new file mode 100644 index 0000000..364893d --- /dev/null +++ b/src/x11/appearance.lisp @@ -0,0 +1,120 @@ +(in-package #:lime.x11) + +;;;; Window styling belongs to the adapter, not saved layout intent. + +(defstruct window-appearance + (border-width 0) + (focused-border "#ffffff") + (unfocused-border "#444444") + (inner-gap 0) + (outer-gap 0)) + +(defparameter *default-window-appearance* (make-window-appearance)) + +(defun %window-appearance (backend) + (or (x11-backend-window-appearance backend) *default-window-appearance*)) + +(defun %validate-window-appearance (appearance) + (unless (and (typep appearance 'window-appearance) + (every (lambda (value) (typep value '(integer 0 65535))) + (list (window-appearance-border-width appearance) + (window-appearance-inner-gap appearance) + (window-appearance-outer-gap appearance))) + (every (lambda (color) + (and (stringp color) (= (length color) 7) + (char= (char color 0) #\#) + (every (lambda (c) (digit-char-p c 16)) + (subseq color 1)))) + (list (window-appearance-focused-border appearance) + (window-appearance-unfocused-border appearance)))) + (error 'invalid-transition + :description "Appearance requires integer pixel sizes from 0 to 65535 and #RRGGBB border colors.")) + appearance) + +(defun %gap-axis (position extent area-position area-extent inner outer) + "Inset one tile axis, splitting odd inner gaps without rounding drift." + (let* ((before (if (= position area-position) outer (ceiling inner 2))) + (after (if (= (+ position extent) (+ area-position area-extent)) + outer (floor inner 2))) + ;; Even an absurd gap setting must leave a usable one-pixel client. + (available (max 0 (1- extent))) + (total (+ before after))) + (when (> total available) + (setf before (floor (* before available) total) + after (- available before))) + (values (+ position before) (max 1 (- extent before after))))) + +(defun %styled-client-geometry (backend client-id geometry work-area tiled-p + &key visible-tile-count) + "Return content geometry and border width, fitting the complete outer frame. + +Gaps apply only to tiles. A Head's sole visible tile has neither gaps nor +borders in any layout, including monocle. It still respects the work area +and normal hints (unlike true fullscreen). +Size hints may shrink a tile but cannot push it into its neighbor. Floats +retain their borders and may grow to their hints within the work area." + (let* ((style (%window-appearance backend)) + (sole-tile-p (and tiled-p (eql visible-tile-count 1))) + (gapped-p (and tiled-p (not sole-tile-p))) + (inner (if gapped-p (window-appearance-inner-gap style) 0)) + (outer (if gapped-p (window-appearance-outer-gap style) 0))) + (multiple-value-bind (x width) + (%gap-axis (geometry-x geometry) (geometry-width geometry) + (x11-work-area-x work-area) (x11-work-area-width work-area) + inner outer) + (multiple-value-bind (y height) + (%gap-axis (geometry-y geometry) (geometry-height geometry) + (x11-work-area-y work-area) (x11-work-area-height work-area) + inner outer) + (let* ((border (min (if sole-tile-p 0 (window-appearance-border-width style)) + (floor (1- (min width height)) 2))) + (content (make-geometry :x x :y y :width (- width (* 2 border)) + :height (- height (* 2 border)))) + (info (backend-client-icccm-info backend client-id))) + (values + (constrain-geometry-to-normal-hints + content (and info (icccm-client-info-normal-hints info)) + :bounds-x (if tiled-p x (x11-work-area-x work-area)) + :bounds-y (if tiled-p y (x11-work-area-y work-area)) + :bounds-width (if tiled-p (geometry-width content) + (max 1 (- (x11-work-area-width work-area) (* 2 border)))) + :bounds-height (if tiled-p (geometry-height content) + (max 1 (- (x11-work-area-height work-area) (* 2 border))))) + border)))))) + +(defun %border-pixel (backend color) + "Allocate through the actual screen colormap, once per distinct RGB color." + (or (gethash color (x11-backend-border-colors backend)) + (setf (gethash color (x11-backend-border-colors backend)) + (xlib:alloc-color + (xlib:screen-default-colormap (x11-backend-x-screen backend)) + (xlib:make-color + :red (/ (parse-integer color :start 1 :end 3 :radix 16) 255.0) + :green (/ (parse-integer color :start 3 :end 5 :radix 16) 255.0) + :blue (/ (parse-integer color :start 5 :end 7 :radix 16) 255.0)))))) + +(defun %prune-border-colors (backend) + "Release colors no longer used after a configuration install or rollback." + (let* ((style (%window-appearance backend)) + (used (list (window-appearance-focused-border style) + (window-appearance-unfocused-border style))) + (table (x11-backend-border-colors backend))) + (maphash (lambda (color pixel) + (unless (member color used :test #'equal) + (xlib:free-colors + (xlib:screen-default-colormap (x11-backend-x-screen backend)) + (list pixel)) + (remhash color table))) + table))) + +(defun %remember-client-border (backend client-id window) + (let ((table (x11-backend-original-border-widths backend))) + (unless (nth-value 1 (gethash client-id table)) + (setf (gethash client-id table) (xlib:drawable-border-width window))))) + +(defun %restore-client-border (backend client-id window) + (multiple-value-bind (width present-p) + (gethash client-id (x11-backend-original-border-widths backend)) + (when present-p + (setf (xlib:drawable-border-width window) width) + (remhash client-id (x11-backend-original-border-widths backend))))) diff --git a/src/x11/attention.lisp b/src/x11/attention.lisp new file mode 100644 index 0000000..df0c761 --- /dev/null +++ b/src/x11/attention.lisp @@ -0,0 +1,103 @@ +(in-package #:lime.x11) + +;;;; Live application attention, independent of Activities and checkpoints. + +(declaim (ftype function render-head-bars)) + +(defun backend-client-needs-attention-p (backend client-id) + "Whether a managed client currently requests attention through either protocol." + (plusp (gethash client-id (x11-backend-attention-clients backend) 0))) + +(defun backend-attention-client-ids (backend &key activity-id) + "Return unique requesting clients in stable order, optionally scoped to an Activity." + (let ((world (x11-backend-world backend))) + (sort (loop for activity in (list-activities world) + when (or (null activity-id) (equal activity-id (activity-id activity))) + append (remove-if-not + (lambda (id) (backend-client-needs-attention-p backend id)) + (if activity-id + (activity-available-client-ids world activity-id) + (copy-list (activity-client-ids activity))))) + #'string< :key #'princ-to-string))) + +(defun %attention-set-source (backend client-id bit enabled-p) + (let* ((table (x11-backend-attention-clients backend)) + (old (gethash client-id table 0)) + (new (if enabled-p (logior old bit) (logandc2 old bit)))) + (if (zerop new) (remhash client-id table) (setf (gethash client-id table) new)) + (/= old new))) + +(defun %attention-wm-hints (window) + ;; CLX's WM-HINTS structure does not expose UrgencyHint. Read the wire + ;; flags, bounded and type-checked, without discarding fields we don't own. + (multiple-value-bind (data type format) + (xlib:get-property window :WM_HINTS :type :WM_HINTS :end 9) + (declare (ignore type)) + (and (eql format 32) data))) + +(defun %attention-refresh-client (backend client-id window) + (let ((hints (%attention-wm-hints window))) + (%attention-set-source backend client-id 1 (and hints (logbitp 8 (first hints))))) + (%attention-set-source + backend client-id 2 + (member (xlib:intern-atom (x11-backend-display backend) :_NET_WM_STATE_DEMANDS_ATTENTION) + (%ewmh-window-state-atoms window) :test #'eql))) + +(defun %attention-selected-client-p (backend client-id) + "Only the selected, rendered input target counts, not each Head's saved focus. + +A palette grab or deliberate root focus is not attention to an application." + (let* ((head-id (x11-backend-focused-head-id backend)) + (presentation (current-presentation (x11-backend-world backend) head-id)) + (info (backend-client-icccm-info backend client-id))) + (and (not (x11-backend-focus-root-override-p backend)) + (not (x11-backend-ui-session backend)) + info (eq :normal (icccm-client-info-wm-state info)) + (or (icccm-client-info-accepts-input-p info) + (icccm-client-info-take-focus-p info)) + (equal client-id (or (ewmh-fullscreen-client-id-for-head backend head-id) + (and presentation (presentation-focus-client-id presentation)))) + (equal head-id (ewmh-active-head-id-for-client backend client-id))))) + +(defun %attention-acknowledge-client (backend client-id) + "Clear only attention hints when the user attends to this window." + (when (and (backend-client-needs-attention-p backend client-id) + (%attention-selected-client-p backend client-id) + (%attention-has-input-focus-p backend client-id)) + (let ((window (gethash client-id (x11-backend-client-windows backend)))) + (when window + (let ((hints (%attention-wm-hints window))) + (when (and hints (logbitp 8 (first hints))) + (setf (first hints) (logandc2 (first hints) 256)) + (xlib:change-property window :WM_HINTS hints :WM_HINTS 32))) + (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_DEMANDS_ATTENTION nil) + (remhash client-id (x11-backend-attention-clients backend)) + t)))) + +(defun %attention-has-input-focus-p (backend client-id) + "Verify real X focus, including application-owned child widgets. + +This roundtrip runs only for a pending alert, never as an idle poll. In +particular a failed SetInputFocus or an unanswered WM_TAKE_FOCUS is not an +acknowledgement. Bound ancestor traversal for unusual client hierarchies." + (let ((target (gethash client-id (x11-backend-client-windows backend))) + (focus (xlib:input-focus (x11-backend-display backend)))) + (loop repeat 64 + while (and target (typep focus 'xlib:window)) + when (= (xlib:window-id target) (xlib:window-id focus)) return t + when (= (xlib:window-id focus) (xlib:window-id (x11-backend-root backend))) return nil + do (setf focus (nth-value 1 (xlib:query-tree focus)))))) + +(defun %attention-acknowledge-selected (backend) + ;; Copy first: acknowledgement removes entries. Usually this list is empty. + (dolist (id (backend-attention-client-ids backend)) + (%attention-acknowledge-client backend id))) + +(defun %attention-request (backend client-id enabled-p) + "Set EWMH attention without changing focus, visibility, leases, or layouts." + (let ((window (gethash client-id (x11-backend-client-windows backend)))) + (when window + (%attention-set-source backend client-id 2 enabled-p) + (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_DEMANDS_ATTENTION enabled-p) + (%attention-acknowledge-client backend client-id) + (render-head-bars backend)))) diff --git a/src/x11/backend.lisp b/src/x11/backend.lisp new file mode 100644 index 0000000..509747a --- /dev/null +++ b/src/x11/backend.lisp @@ -0,0 +1,669 @@ +(in-package #:lime.x11) + +;;;; A deliberately small CLX bridge +;;; +;;; This file is not a full ICCCM/EWMH window manager. It is the first real +;;; adapter for the model: one X11 root window carries one or more Lime Heads, +;;; MapRequest creates a client in the selected Head's current Activity, and +;;; applying live Presentations performs the resulting map/unmap/configure +;;; effects. + +(defstruct x11-head + "One configured X11 rectangle rendered as one logical Lime Head." + head-id + x + y + width + height + ;; NIL for a manually configured rectangle. RandR discovery associates a + ;; logical Head with an active CRTC and records the output(s) feeding it. + ;; Mirrored outputs share one CRTC and therefore one Head. + output-id + output-ids + output-name) + +(defstruct x11-work-area + "The client-usable rectangle of one X11 Head. + +The Head remains the physical output rectangle. A work area is the small +adapter-level refinement used by ordinary tiled and floating clients after +Lime has reserved space for its own Head-local UI. It deliberately is not a +core-model concept: saved View geometry stays normalized and portable." + x + y + width + height) + +(defstruct x11-randr-topology + "One observed RandR hardware snapshot, owned by the X11 adapter." + major-version + minor-version + timestamp + config-timestamp + primary-output-id + (outputs '()) + (heads '())) + +(defstruct (x11-backend (:constructor %make-x11-backend)) + display + display-name + ;; This is CLX's server-level screen object, not Lime's Head model. + x-screen + root + cursor-set + world + ;; The first configured Head, retained for single-Head compatibility. + head-id + ;; The Activity on the focused Head. MapRequest routing reads the active + ;; Presentation directly; this slot is a convenient compatibility snapshot. + activity-id + ;; Startup policy only; saved Views and existing drafts keep their layouts. + (default-layout :master-stack) + ;; Head id selected for new-window routing and command targeting. + focused-head-id + ;; A background click deliberately focuses root without destroying the + ;; selected Presentation's saved client focus target. + (focus-root-override-p nil) + ;; Head id -> X11-HEAD and a stable rendering order for that table. + (heads (make-hash-table :test #'equal)) + (head-ids '()) + ;; :EXPLICIT, :RANDR, or :FALLBACK. The core knows only stable Head ids. + head-source + ;; The reusable Head UI owns these override-redirect windows. Reserving a + ;; positive height creates a work area immediately below each bar; zero is + ;; an intentionally UI-less configuration for experiments and tests. + (head-bars (make-hash-table :test #'equal)) + (head-bar-height 22) + ;; Fast segment functions or managed STATUS-PROVIDER objects. Managed I/O + ;; lives off-thread; the bar reads only cached strings while painting. + (head-bar-status-providers '()) + ;; Managed providers cache data off-thread; only this backend draws it. + status-runtime + ;; Adapter-only styling; saved layouts retain their ungapped rectangles. + window-appearance + (border-colors (make-hash-table :test #'equal)) + (original-border-widths (make-hash-table :test #'equal)) + ;; x11/randr.lisp owns these snapshots. An event only marks topology + ;; pending; it never silently reassigns Activities, Views, or Leases. + randr-topology + (randr-topology-dirty-p nil) + ;; An in-progress Super+pointer gesture, owned by x11/pointer.lisp. + ;; It is frontend-only state; geometry continues to live in the model. + pointer-drag + ;; Input bindings are installed by x11/input.lisp and owned by this backend. + (keybindings (make-hash-table :test #'equal)) + last-command-error + ;; Bounded diagnostic history and the event being dispatched. The separate + ;; resilience module owns error policy; these are never checkpoint state. + (diagnostics '()) + (expected-x-error-count 0) + event-context + ;; The persistence module owns disk state and worker lifecycle; no CLX + ;; resource or config closure is sent to that worker. + session-persistence + ;; A loaded LIME.CONFIG object, plus the source required for an explicit + ;; reload. Configuration is adapter policy: it never becomes Activity, + ;; View, Presentation, or Lease data in the pure world. + configuration + configuration-source + configuration-name + ;; x11/ui.lisp owns the ephemeral command-palette session and its + ;; override-redirect overlay. Neither value belongs in the core world. + ui-session + ui-overlay + ;; Lime client id -> ICCCM-CLIENT-INFO. X11/ICCCM owns this cache and + ;; refreshes it from client properties; the pure model never sees CLX data. + (icccm-clients (make-hash-table :test #'equal)) + ;; Live protocol requests only, never checkpoint or persistence data. + ;; ATTENTION owns the source bits: ICCCM urgency and EWMH attention. + (attention-clients (make-hash-table :test #'equal)) + ;; Lime client id -> T for an application-requested EWMH fullscreen state. + ;; The target Head is deliberately derived from the client's current Lease, + ;; so a fullscreen client follows a legitimate View/Head move without + ;; becoming a second, monitor-global workspace concept. + (fullscreen-clients (make-hash-table :test #'equal)) + ;; EWMH compatibility state stays entirely in the adapter. The supporting + ;; window identifies Lime to other desktop clients; CLIENT-ORDER preserves + ;; EWMH's initial-map order while EXTERNAL-WINDOWS holds dock/desktop + ;; surfaces that must be mapped but must never enter an Activity or View. + ewmh-supporting-window + (ewmh-client-order '()) + (ewmh-external-windows (make-hash-table :test #'eql)) + ;; Lime client id -> recognized _NET_WM_WINDOW_TYPE keywords. This is + ;; metadata used by first-placement policy, not persistent task state. + (ewmh-window-types (make-hash-table :test #'equal)) + ;; Lime client id -> CLX window + (client-windows (make-hash-table :test #'equal)) + ;; XID -> Lime client id + (window-clients (make-hash-table :test #'eql)) + ;; XID -> number of UnmapNotify events caused by Lime's renderer. ICCCM + ;; withdrawal is signaled with the same X event, so lifecycle consumes one + ;; of these tokens before treating an unmap as an application withdrawal. + (pending-unmaps (make-hash-table :test #'eql)) + (quit-requested-p nil) + (running-p nil)) + +(defun %ensure-head (world head-id) + (handler-case + (find-head world head-id) + (unknown-entity () + (create-head world head-id)))) + +(defun %ensure-activity (world activity-id) + (handler-case + (find-activity world activity-id) + (unknown-entity () + (create-activity world activity-id "Scratch")))) + +(defun %ensure-active-presentation (world head-id activity-id + &key (default-layout :master-stack)) + (%ensure-head world head-id) + (%ensure-activity world activity-id) + (or (current-presentation world head-id) + (open-activity-draft world head-id activity-id :default-layout default-layout))) + +(defun %rectangles-overlap-p (first second) + (and (< (x11-head-x first) + (+ (x11-head-x second) (x11-head-width second))) + (< (x11-head-x second) + (+ (x11-head-x first) (x11-head-width first))) + (< (x11-head-y first) + (+ (x11-head-y second) (x11-head-height second))) + (< (x11-head-y second) + (+ (x11-head-y first) (x11-head-height first))))) + +(defun %validate-head (head root) + (unless (typep head 'x11-head) + (error 'invalid-transition + :description "An X11 Head must be an X11-HEAD structure.")) + (unless (and (x11-head-head-id head) + (integerp (x11-head-x head)) + (integerp (x11-head-y head)) + (plusp (x11-head-width head)) + (plusp (x11-head-height head))) + (error 'invalid-transition + :description "An X11 Head needs an id, integer origin, and positive size.")) + (unless (and (>= (x11-head-x head) 0) + (>= (x11-head-y head) 0) + (<= (+ (x11-head-x head) (x11-head-width head)) + (xlib:drawable-width root)) + (<= (+ (x11-head-y head) (x11-head-height head)) + (xlib:drawable-height root))) + (error 'invalid-transition + :description "An X11 Head must fit inside the root window.")) + head) + +(defun %configure-heads (root head-id heads) + "Validate explicit Head rectangles or make one rectangle for ROOT." + (let ((configured-heads (or heads + (list (make-x11-head :head-id head-id + :x 0 + :y 0 + :width (xlib:drawable-width root) + :height (xlib:drawable-height root))))) + (seen (make-hash-table :test #'equal))) + (dolist (head configured-heads) + (%validate-head head root) + (when (gethash (x11-head-head-id head) seen) + (error 'invalid-transition + :description "Two configured X11 Heads use the same id.")) + (setf (gethash (x11-head-head-id head) seen) t) + (dolist (other configured-heads) + (when (and (not (eq head other)) + (%rectangles-overlap-p head other)) + (error 'invalid-transition + :description "Configured X11 Head rectangles may not overlap.")))) + configured-heads)) + +(defun %choose-configured-heads (display root head-id heads head-discovery) + "Return validated Heads, their source, and an optional RandR snapshot. + +An explicit HEADS argument always wins. :AUTO uses RandR when it can find at +least one active output; :NONE keeps the historical single-root Head fallback. +This is startup discovery only, not an output-management policy." + (unless (member head-discovery '(:auto :none)) + (error 'invalid-transition + :description "HEAD-DISCOVERY must be :AUTO or :NONE.")) + (cond + (heads + (values (%configure-heads root head-id heads) :explicit nil)) + ((eq head-discovery :auto) + (let ((topology (x11-randr-discover-topology display root))) + (if (and topology (x11-randr-topology-heads topology)) + (values (%configure-heads root head-id + (x11-randr-topology-heads topology)) + :randr topology) + (values (%configure-heads root head-id nil) :fallback nil)))) + (t + (values (%configure-heads root head-id nil) :fallback nil)))) + +(defun %head-for-id (backend head-id) + (or (gethash head-id (x11-backend-heads backend)) + (error 'invalid-transition + :description (format nil "Head ~S has no configured rectangle." + head-id)))) + +(defun %head-bar-reserved-height (backend head) + "Return the usable reserved bar height for HEAD. + +Keep at least one pixel of client area on an unusually tiny test Head; a +normal X server Head is naturally much larger than the default 22 pixels." + (min (max 0 (x11-backend-head-bar-height backend)) + (max 0 (1- (x11-head-height head))))) + +(defun x11-head-work-area (backend head-or-id) + "Return HEAD-OR-ID's client work area after Lime's top bar reservation. + +Ordinary layouts and floats use this rectangle. EWMH fullscreen intentionally +uses the physical X11-HEAD rectangle instead, so games and video players do +not inherit a decorative gap." + (let* ((head (if (x11-head-p head-or-id) + head-or-id + (%head-for-id backend head-or-id))) + (bar-height (%head-bar-reserved-height backend head))) + (make-x11-work-area :x (x11-head-x head) + :y (+ (x11-head-y head) bar-height) + :width (x11-head-width head) + :height (- (x11-head-height head) bar-height)))) + +(defun %client-id-for-window (window) + (format nil "x11-~X" (xlib:window-id window))) + +(defun %backend-client-id (backend window) + (gethash (xlib:window-id window) (x11-backend-window-clients backend))) + +(defun %registered-window-p (backend window) + (%backend-client-id backend window)) + +(defun %register-window (backend client-id window) + (setf (gethash client-id (x11-backend-client-windows backend)) window + (gethash (xlib:window-id window) + (x11-backend-window-clients backend)) client-id) + client-id) + +(defun %forget-window (backend window) + (let ((client-id (%backend-client-id backend window))) + (when client-id + (remhash client-id (x11-backend-client-windows backend)) + (remhash (xlib:window-id window) + (x11-backend-window-clients backend))) + client-id)) + +(defun %unmap-window-id (window-or-id) + "Return an XID for WINDOW-OR-ID, which may be useful in server-free tests." + (if (integerp window-or-id) + window-or-id + (xlib:window-id window-or-id))) + +(defun %note-pending-unmap (backend window-or-id) + "Record one renderer-originated unmap before issuing it to the X server." + (let* ((window-id (%unmap-window-id window-or-id)) + (pending-unmaps (x11-backend-pending-unmaps backend))) + (incf (gethash window-id pending-unmaps 0)) + window-id)) + +(defun %consume-pending-unmap-p (backend window-or-id) + "Consume one renderer-originated unmap token, returning whether one existed." + (let* ((window-id (%unmap-window-id window-or-id)) + (pending-unmaps (x11-backend-pending-unmaps backend)) + (count (gethash window-id pending-unmaps 0))) + (when (plusp count) + (if (= count 1) + (remhash window-id pending-unmaps) + (setf (gethash window-id pending-unmaps) (1- count))) + t))) + +(defun %forget-pending-unmaps (backend window-or-id) + "Discard stale renderer-unmap bookkeeping for a gone window." + (remhash (%unmap-window-id window-or-id) (x11-backend-pending-unmaps backend))) + +;; These implementations live in focused modules loaded after the backend. +;; Keeping the declarations here lets this file own connection setup and the +;; event loop without turning it into a renderer or lifecycle policy bucket. +(declaim (ftype function manage-window + %prepare-session-persistence + %adopt-session-clients + %poll-session-persistence + %stop-session-persistence + %forget-navigation-state + %handle-display-error + %call-with-client-race-handling + %call-with-cleanup-diagnostics + backend-release-input + %handle-configure-request + %handle-destroy-notify + %handle-unmap-notify + %handle-property-notify + icccm-set-client-state + icccm-withdraw-client + icccm-handle-client-message + x11-randr-discover-topology + x11-randr-topology-heads + x11-randr-enable-notifications + x11-randr-handle-change + ewmh-initialize + ewmh-shutdown + ewmh-handle-client-message + initialize-head-bars + shutdown-head-bars + %handle-head-bar-exposure + %handle-head-bar-button-press + %handle-head-bar-motion + %handle-head-bar-leave + %initialize-pointer-cursors + %shutdown-pointer-cursors + %shutdown-cursor-session-settings + %handle-cursor-settings-selection-clear + %handle-button-press + %handle-button-release + %handle-motion-notify + %coalesce-drag-motion + %handle-key-press + %handle-ui-key-press + %handle-ui-button-press + %handle-ui-motion + %handle-ui-leave + %handle-ui-exposure + backend-close-command-palette + install-default-keybindings)) + +(defun start-backend (&key display-name + (world (make-world) world-supplied-p) + session-file + (head-id "x11-root") + (activity-id "scratch") + (default-layout :master-stack) + heads + (head-discovery :auto) + (head-bar-height 22) + (install-default-keybindings-p t) + (keybinding-modifiers '(:mod-4))) + "Claim one X11 root window and return a Lime backend. + +DISPLAY-NAME follows the normal DISPLAY syntax, e.g. ":1" for a Xephyr +server. Start this only in a nested server or another X11 session without an +existing window manager: selecting :SUBSTRUCTURE-REDIRECT is exclusive. + +HEADS is an optional list of non-overlapping X11-HEAD rectangles. Each +rectangle becomes one Head. Without it, the root window is one Head named +by HEAD-ID unless HEAD-DISCOVERY is :AUTO and RandR reports active outputs. +In that normal case each active CRTC becomes one Head named for its output; +mirrored outputs share a single Head. Set HEAD-DISCOVERY to :NONE to force the +single-root fallback. + +SESSION-FILE is NIL for a fresh nonpersistent backend, :DEFAULT for the +display-specific XDG state path, or a pathname. It cannot be combined with an +explicit WORLD. Restored clients retain their verified draft/checkpoint roles. + +HEAD-BAR-HEIGHT reserves that many pixels at the top of each Head for Lime's +first reusable UI surface. Set it to zero to run without bars and use the +full physical Head as the ordinary client area. + +Lime creates the bootstrap Scratch Activity with an unsaved blank live draft +on each initial Head in DEFAULT-LAYOUT (:MASTER-STACK by default); it does not +manufacture permanent empty Views or change an existing draft's layout. Unless +INSTALL-DEFAULT-KEYBINDINGS-P is NIL, Lime installs its small Super starter +map before returning. KEYBINDING-MODIFIERS accepts the same modifier list or +integer mask as BIND-KEY; set the flag to NIL for a fully custom map." + (unless (member default-layout '(:manual :master-stack :monocle)) + (error 'invalid-transition + :description "DEFAULT-LAYOUT must be :MANUAL, :MASTER-STACK, or :MONOCLE.")) + (when (and session-file world-supplied-p) + (error "Choose an explicit WORLD or SESSION-FILE, not both.")) + (let* ((display (xlib:open-default-display display-name)) + (x-screen (xlib:display-default-screen display)) + (root (xlib:screen-root x-screen))) + (unless (and (integerp head-bar-height) (not (minusp head-bar-height))) + (error 'invalid-transition + :description "HEAD-BAR-HEIGHT must be a non-negative integer.")) + (multiple-value-bind (configured-heads head-source randr-topology) + (%choose-configured-heads display root head-id heads head-discovery) + (let* ((primary-head-id (x11-head-head-id (first configured-heads))) + (head-table (make-hash-table :test #'equal)) + (backend (%make-x11-backend :display display :display-name (or display-name (uiop:getenv "DISPLAY")) + :x-screen x-screen + :root root + :world world + :head-id primary-head-id + :activity-id activity-id + :default-layout default-layout + :focused-head-id primary-head-id + :heads head-table + :head-ids (mapcar #'x11-head-head-id + configured-heads) + :head-source head-source + :randr-topology randr-topology + :head-bar-height head-bar-height))) + ;; Request-specific race handling never suppresses root ownership or + ;; key-grab conflicts. Synchronous failed queries must unwind, not wait + ;; forever for a reply the server will never send. + (setf (xlib:display-error-handler display) + (lambda (error-display error-key &rest key-vals) + (apply #'%handle-display-error backend error-display error-key + key-vals))) + (dolist (head configured-heads) + (setf (gethash (x11-head-head-id head) head-table) head)) + (handler-case + (progn + ;; BadAccess is reported by the X server if another WM already owns + ;; this root. Finish the roundtrip before changing shared root state. + (setf (xlib:window-event-mask root) + '(:substructure-redirect :substructure-notify :button-press)) + (xlib:display-finish-output display) + (%prepare-session-persistence backend session-file) + (setf world (x11-backend-world backend)) + (%initialize-pointer-cursors backend) + (when (eq head-source :randr) + (x11-randr-enable-notifications backend)) + (dolist (head configured-heads) + (%ensure-active-presentation + world + (x11-head-head-id head) + activity-id :default-layout default-layout)) + (setf (x11-backend-activity-id backend) + (presentation-activity-id + (current-presentation world (x11-backend-focused-head-id backend)))) + (ewmh-initialize backend) + ;; Create the Head UI before adopting existing clients. Subsequent + ;; render passes raise it again after client reconciliation. + (initialize-head-bars backend) + (%adopt-session-clients backend) + (dolist (window (multiple-value-bind (children parent root-window) + (xlib:query-tree root) + (declare (ignore parent root-window)) + children)) + (%call-with-client-race-handling + backend + (lambda () + (when (and (not (%registered-window-p backend window)) + (not (eq (xlib:window-override-redirect window) :on)) + (eq (xlib:window-map-state window) :viewable)) + (manage-window backend window))))) + (when session-file (apply-active-presentation backend)) + (when install-default-keybindings-p + (install-default-keybindings backend + :modifiers keybinding-modifiers)) + backend) + (error (condition) + (ignore-errors (%stop-session-persistence backend nil)) + (%forget-navigation-state backend) + (xlib:close-display display :abort t) + (error condition))))))) + +(defun run-event-loop (backend &key (timeout 0.1) before-event) + "Process CLX events until STOP-BACKEND clears BACKEND's running flag. + +BEFORE-EVENT, when supplied, runs at an event-loop boundary before waiting for +the next X event. The ordinary adapter leaves it NIL; LIME.DEV uses the hook +to serialize REPL requests on this X-owning thread rather than letting a +remote REPL race CLX or the Activity/View world." + (setf (x11-backend-running-p backend) t + (x11-backend-quit-requested-p backend) nil) + (loop while (x11-backend-running-p backend) + do (when before-event + (funcall before-event backend)) + ;; A control request may have asked to quit at this boundary. + (unless (x11-backend-running-p backend) (return)) + (%poll-session-persistence backend) + (%call-with-client-race-handling + backend (lambda () (%dispatch-next-event backend timeout)))) + backend) + +(defun %dispatch-next-event (backend timeout) + "Handle at most one event so busy clients cannot starve the control mailbox." + (setf (x11-backend-event-context backend) '(:kind :wait)) + (xlib:event-case ((x11-backend-display backend) + :timeout timeout + :discard-p t + :force-output-p t) + (:map-request (window) + (%note-backend-event backend :map-request window) + (manage-window backend window) + t) + (:configure-request (parent window above-sibling x y width height + border-width value-mask) + (%note-backend-event backend :configure-request window) + (%handle-configure-request backend window x y width height + border-width value-mask + parent above-sibling) + t) + (:client-message (window type format data) + (%note-backend-event backend :client-message window) + ;; ICCCM owns WM_CHANGE_STATE; the narrow EWMH slice owns its + ;; own atoms. Keeping both calls separate avoids turning the + ;; EWMH module into a catch-all client-message dispatcher. + (unless (%handle-status-notification backend window type) + (unless (icccm-handle-client-message backend window type format data) + (ewmh-handle-client-message backend window type format data))) + t) + (:rr-screen-change-notify () + (%note-backend-event backend :randr) + (x11-randr-handle-change backend) + t) + (:rr-crtc-change-notify () + (%note-backend-event backend :randr) + (x11-randr-handle-change backend) + t) + (:rr-output-change-notify () + (%note-backend-event backend :randr) + (x11-randr-handle-change backend) + t) + (:key-press (code state) + (%note-backend-event backend :key-press) + (if (x11-backend-ui-session backend) + (%handle-ui-key-press backend code state) + (%handle-key-press backend code state)) + t) + (:exposure (window count) + (%note-backend-event backend :exposure window) + (unless (%handle-head-bar-exposure backend window count) + (%handle-ui-exposure backend window count)) + t) + (:button-press (window root-x root-y code state time) + (%note-backend-event backend :button-press window) + (unless (%handle-ui-button-press backend window root-x root-y code) + (unless (%handle-head-bar-button-press backend window root-x root-y + code state time) + (%handle-button-press backend window root-x root-y code state time))) + t) + (:button-release (code root-x root-y) + (%note-backend-event backend :button-release) + (%handle-button-release backend code root-x root-y) + t) + (:motion-notify (window root-x root-y state) + (%note-backend-event backend :motion-notify window) + (unless (%handle-ui-motion backend window root-x root-y) + (unless (%handle-head-bar-motion backend window root-x root-y) + (when (x11-backend-pointer-drag backend) + (multiple-value-bind (latest-x latest-y) + (%coalesce-drag-motion backend window root-x root-y state) + (%handle-motion-notify backend latest-x latest-y state))))) + t) + (:enter-notify (window root-x root-y) + (%note-backend-event backend :enter-notify window) + (unless (%handle-ui-motion backend window root-x root-y) + (%handle-head-bar-motion backend window root-x root-y)) + t) + (:leave-notify (window) + (%note-backend-event backend :leave-notify window) + (%handle-ui-leave backend window) + (%handle-head-bar-leave backend window) + t) + (:destroy-notify (window) + (%note-backend-event backend :destroy-notify window) + (%handle-destroy-notify backend window) + t) + (:unmap-notify (event-window window configure-p) + (%note-backend-event backend :unmap-notify window) + (%handle-unmap-notify backend event-window window configure-p) + t) + (:property-notify (window atom) + (%note-backend-event backend :property-notify window) + (%handle-property-notify backend window atom) + t) + (:selection-clear (window selection) + (%note-backend-event backend :selection-clear window) + (%handle-cursor-settings-selection-clear backend window selection) + t) + (:focus-in (window mode) + (%note-backend-event backend :focus-in window) + ;; Globally-active clients can answer WM_TAKE_FOCUS asynchronously. + ;; Grab/ungrab notifications alone are not user acknowledgement. + (when (eq mode :normal) + (let ((id (%backend-client-id backend window))) + (when (and id (%attention-acknowledge-client backend id)) + (render-head-bars backend)))) + t) + (otherwise () t))) + +(defun %note-backend-event (backend kind &optional window) + ;; CLX keeps the current event queued when a handler unwinds, even with + ;; :DISCARD-P T. Mark it consumed before mutating state: a stale MapRequest + ;; must not loop forever, and a failed command must not replay on resume. + ;; Other queued events remain intact. + (xlib:discard-current-event (x11-backend-display backend)) + (setf (x11-backend-event-context backend) + (list :kind kind :window-id (and window (xlib:window-id window))))) + +(defun stop-backend (backend &key (save-session-p t)) + "Remap managed clients, release the root selection, and close CLX cleanly." + (when (x11-backend-running-p backend) + (setf (x11-backend-running-p backend) nil)) + (let ((display (x11-backend-display backend))) + (when display + ;; Each cleanup is independent: a stale resource must not prevent the + ;; next client's restoration or the final connection close. + (flet ((cleanup (function) + (%call-with-cleanup-diagnostics backend function))) + (unwind-protect + (progn + (cleanup (lambda () (%stop-session-persistence backend save-session-p))) + (cleanup (lambda () (%forget-navigation-state backend))) + (cleanup (lambda () (%shutdown-status-runtime backend))) + (cleanup (lambda () (backend-release-input backend))) + (cleanup (lambda () (ewmh-shutdown backend))) + (cleanup (lambda () (shutdown-head-bars backend))) + (cleanup (lambda () (%shutdown-cursor-session-settings backend))) + (cleanup (lambda () (%shutdown-pointer-cursors backend))) + (maphash (lambda (client-id window) + ;; Leave the server in the conventional visible state before + ;; Lime relinquishes ownership of the root. + (cleanup (lambda () + (icccm-set-client-state backend client-id window :normal :force-p t) + (%restore-client-border backend client-id window) + (xlib:map-window window)))) + (x11-backend-client-windows backend)) + (cleanup (lambda () (xlib:display-finish-output display)))) + (unwind-protect + (cleanup (lambda () (xlib:close-display display :abort t))) + (setf (x11-backend-display backend) nil)))))) + backend) + +(defun run-demo (&key display-name) + "Start the adapter and run it until interrupted. + +Use this in Xephyr, then launch xterms into the same nested DISPLAY." + (let ((backend (start-backend :display-name display-name))) + (unwind-protect + (run-event-loop backend) + (stop-backend backend)))) diff --git a/src/x11/bar.lisp b/src/x11/bar.lisp new file mode 100644 index 0000000..572a620 --- /dev/null +++ b/src/x11/bar.lisp @@ -0,0 +1,774 @@ +(in-package #:lime.x11) + +;;;; Reusable Head bar +;;; +;;; This is Lime's first persistent UI surface. It intentionally knows only +;;; about adapter facts (physical Head rectangles, ICCCM titles, X11 windows) +;;; plus the public model snapshot it is rendering. The command palette is a +;;; separate temporary overlay; both can evolve behind a later theme/renderer +;;; boundary without making UI state part of Activities, Views, or Leases. + +(defstruct head-bar-style + "Adapter-only bar appearance. NIL TITLE-EDGE-COLOR disables the two hairlines." + (padding-x 10) + (background "#060a0c") + (foreground "#ffdbb0") + (focused-background "#121f25") + (focused-foreground "#ffac54") + (unfocused-background "#0b1216") + (unfocused-foreground "#a8adb0") + ;; NIL preserves the original shared colors for existing configurations. + accent-color + menu-label-color + logo-color + (separator-color "#b88755") + (attention-color "#ffac54") + (attention-marker "!") + (attention-indicator-p t) + (title-edge-color "#40535d")) + +(defparameter *default-head-bar-style* (make-head-bar-style)) + +(declaim (ftype function lime-configuration-bar-style)) + +(defun %head-bar-style (backend) + (declare (notinline lime-configuration-bar-style)) + (let ((configuration (x11-backend-configuration backend))) + (if configuration (lime-configuration-bar-style configuration) + *default-head-bar-style*))) + +(defun %head-bar-style-colors (style) + (remove nil (list (head-bar-style-background style) + (head-bar-style-foreground style) + (head-bar-style-focused-background style) + (head-bar-style-focused-foreground style) + (head-bar-style-unfocused-background style) + (head-bar-style-unfocused-foreground style) + (head-bar-style-accent-color style) + (head-bar-style-menu-label-color style) + (head-bar-style-logo-color style) + (head-bar-style-separator-color style) + (head-bar-style-attention-color style) + (head-bar-style-title-edge-color style)))) + +(defun %validate-head-bar-style (style) + (unless (and (typep style 'head-bar-style) + (integerp (head-bar-style-padding-x style)) + (<= 0 (head-bar-style-padding-x style) 128)) + (error 'invalid-transition :description "Bar :PADDING-X must be an integer from 0 to 128 pixels.")) + (unless (and (stringp (head-bar-style-attention-marker style)) + (<= 1 (length (head-bar-style-attention-marker style)) 16) + (notany (lambda (c) (or (< (char-code c) 32) (= (char-code c) 127))) + (head-bar-style-attention-marker style)) + (member (head-bar-style-attention-indicator-p style) '(nil t))) + (error 'invalid-transition :description "Bar attention marker must be 1–16 printable characters; :ATTENTION-INDICATOR-P must be T or NIL.")) + (flet ((rgb-p (color) + (and (stringp color) (= (length color) 7) + (char= (char color 0) #\#) + (every (lambda (c) (digit-char-p c 16)) (subseq color 1))))) + (unless (and (typep style 'head-bar-style) + (every #'rgb-p + (list (head-bar-style-background style) + (head-bar-style-foreground style) + (head-bar-style-focused-background style) + (head-bar-style-focused-foreground style) + (head-bar-style-unfocused-background style) + (head-bar-style-unfocused-foreground style) + (head-bar-style-attention-color style) + (head-bar-style-separator-color style))) + (every (lambda (color) (or (null color) (rgb-p color))) + (list (head-bar-style-title-edge-color style) + (head-bar-style-accent-color style) + (head-bar-style-menu-label-color style) + (head-bar-style-logo-color style)))) + (error 'invalid-transition + :description "Bar colors must be #RRGGBB; :TITLE-EDGE-COLOR, :ACCENT-COLOR, :MENU-LABEL-COLOR, and :LOGO-COLOR may be NIL."))) + style) + +(defun %ui-accent-color (style) + (or (head-bar-style-accent-color style) (head-bar-style-focused-foreground style))) + +(defun %ui-menu-label-color (style) + (or (head-bar-style-menu-label-color style) (head-bar-style-separator-color style))) + +(defstruct head-bar-segment + "One optional right-side status item supplied by user configuration. + +TEXT is rendered as one independently shaped item. CLICK-ACTION, when present, +is a function of (BACKEND HEAD-ID), allowing music, volume, clock, or +other modules to opt into bar interaction without teaching the core about +them." + id + text + ;; Optional pixel budget; fitting remains grapheme-aware in the renderer. + maximum-width + ;; NIL inherits the bar foreground. This also permits data-dependent colors + ;; from a user formatter without embedding markup in application text. + foreground + ;; Optional separately colored logical prefix (typically an icon). The + ;; complete text stays one shaped/clickable item, including RTL labels. + (prefix-length 0) + prefix-foreground + click-action) + +(defun %bar-color-p (color) + (and (stringp color) (= (length color) 7) (char= (char color 0) #\#) + (every (lambda (c) (digit-char-p c 16)) (subseq color 1)))) + +(defun %validate-head-bar-segment (segment) + (unless (and (typep segment 'head-bar-segment) + (or (null (head-bar-segment-foreground segment)) + (%bar-color-p (head-bar-segment-foreground segment))) + (or (null (head-bar-segment-prefix-foreground segment)) + (%bar-color-p (head-bar-segment-prefix-foreground segment))) + (integerp (head-bar-segment-prefix-length segment)) + (<= 0 (head-bar-segment-prefix-length segment) + (length (%single-line-text (head-bar-segment-text segment)))) + (or (null (head-bar-segment-maximum-width segment)) + (and (integerp (head-bar-segment-maximum-width segment)) + (plusp (head-bar-segment-maximum-width segment)))) + (or (null (head-bar-segment-click-action segment)) + (functionp (head-bar-segment-click-action segment)))) + (error 'invalid-transition :description "A status segment needs optional #RRGGBB colors, a prefix length within its text, positive pixel width, and function click action.")) + segment) + +(defstruct x11-head-bar-hit-region + left + right + action) + +(defstruct x11-head-bar + head-id + window + font + canvas + background-gcontext + foreground-gcontext + inverse-foreground-gcontext + colormap + (colors (make-hash-table :test #'equal)) + height + pointer-hand-p + (hit-regions '())) + +;; These public commands live in later files in ASDF load order. The bar +;; invokes them only in response to user input, after the system is loaded. +(declaim (ftype function backend-open-command-palette + backend-open-attention-picker + backend-open-activity-picker + %show-navigation-result + %ui-request-activity-activation + %set-ui-pointer + %ui-window-pointer-position + backend-cycle-layout)) + +(defun %bar-string (value) + (princ-to-string value)) + +(defun %bar-text-width (font text) + "Measure the same shaped run used for painting, with no X roundtrip." + (%text-width font text)) + +(defun %bar-short-text (text maximum-width measure) + "Server-free compatibility entry; real UI fitting supplies grapheme boundaries." + (%fit-text text maximum-width measure)) + +(defun %bar-text-layout (width label layout-token title status measure + &key (padding-x 10) (fit #'%bar-short-text) (status-fit fit) + (label-fit fit) (minimum-label-width 0)) + "Compute text and positions once for both drawing and hit testing. + +MEASURE accepts a string and returns pixel width. Keeping this calculation +server-free makes proportional-font and narrow-Head behavior testable." + (let* ((gap 8) + (title-padding (1+ padding-x)) ; leave the hairline separate from text padding + (separator " | ") + (separator-width (funcall measure separator)) + (logo-x (min width padding-x)) + ;; The separator already supplies the inter-field space. Keep outer + ;; edge padding, without adding a second blank after the logo. + (logo-width (min width (+ padding-x (funcall measure "Lime")))) + (logo (funcall fit "Lime" (max 0 (- logo-width padding-x)) measure)) + (left-x (min width (+ logo-width separator-width))) + (right-edge (max left-x (- width padding-x))) + (available (- right-edge left-x)) + (visible-layout (funcall fit layout-token available measure)) + (layout-width (funcall measure visible-layout)) + ;; Preserve the layout control even if a status provider is verbose. + (status-limit (max 0 (- available layout-width + (min minimum-label-width (floor available 3)) + (if (plusp minimum-label-width) separator-width 0) + (if (plusp layout-width) gap 0))))) + (multiple-value-bind (visible-status status-prefix-length measured-status-width status-runs) + (funcall status-fit status status-limit measure) + (let* ((status-width (or measured-status-width (funcall measure visible-status))) + (status-x (- right-edge status-width)) + (left-limit (max left-x (- status-x (if (plusp status-width) gap 0)))) + (label-room (max 0 (- left-limit left-x layout-width + (if (plusp layout-width) separator-width 0)))) + (label-limit (max (min minimum-label-width label-room) + (- label-room + ;; Reserve title padding and some useful text. + (if (plusp (length title)) (+ 80 (* 2 title-padding) gap) 0)))) + (label-result (multiple-value-list (funcall label-fit label label-limit measure))) + (visible-label (first label-result)) + (label-width (or (third label-result) (funcall measure visible-label))) + (layout-x (+ left-x label-width + (if (and (plusp label-width) (plusp layout-width)) + separator-width 0))) + (title-left (min left-limit (+ layout-x layout-width + (if (plusp layout-width) gap 0)))) + (title-right (if (plusp status-width) left-limit width)) + (title-x (min title-right (+ title-left title-padding))) + (title-width (max 0 (- title-right title-padding title-x))) + (visible-title (funcall fit title title-width measure)) + (separators + (append + (when (and (or (plusp label-width) (plusp layout-width)) + (<= (+ logo-width separator-width) width)) + (list (cons logo-width separator))) + (when (and (plusp label-width) (plusp layout-width)) + (list (cons (+ left-x label-width) separator)))))) + (list :logo logo :logo-x logo-x :logo-width logo-width + :label visible-label :label-x left-x + :label-runs (fourth label-result) + :layout-token visible-layout :layout-x layout-x + :title visible-title :title-x title-x :title-width title-width + :title-left title-left :title-right title-right :separators separators + :status visible-status :status-x status-x + :status-runs status-runs + :status-prefix-length status-prefix-length))))) + +(defun %bar-status-separator-spans (segments prefix-length start-x measure) + "Locate only real, visible inter-item separators, never pipes in item text." + (let ((offset 0) (x start-x) (spans '())) + (loop for segment in segments + for first-p = t then nil + do (unless first-p + (let* ((n (min 3 (max 0 (- prefix-length offset)))) + (text (subseq " | " 0 n))) + (when (plusp n) (push (cons x text) spans)) + (incf offset 3) + (incf x (funcall measure " | ")))) + (when (>= offset prefix-length) (return)) + (let ((text (%bar-string (head-bar-segment-text segment)))) + (incf offset (length text)) + (incf x (funcall measure text)))) + (nreverse spans))) + +(defun %bar-pixel (bar color) + (or (gethash color (x11-head-bar-colors bar)) + (setf (gethash color (x11-head-bar-colors bar)) + (xlib:alloc-color + (x11-head-bar-colormap bar) + (xlib:make-color + :red (/ (parse-integer color :start 1 :end 3 :radix 16) 255.0) + :green (/ (parse-integer color :start 3 :end 5 :radix 16) 255.0) + :blue (/ (parse-integer color :start 5 :end 7 :radix 16) 255.0)))))) + +(defun %prune-head-bar-colors (bar style) + (let ((used (%head-bar-style-colors style))) + (maphash (lambda (color pixel) + (unless (member color used :test #'equal) + (xlib:free-colors (x11-head-bar-colormap bar) (list pixel)) + (remhash color (x11-head-bar-colors bar)))) + (x11-head-bar-colors bar)))) + +(defun %bar-status-hit-spans (segments prefix-length start-x measure) + "Return (LEFT RIGHT SEGMENT) for clickable, actually displayed status text. + +Separators, truncation dots, and entirely clipped segments remain inert." + (let ((offset 0) (x start-x) (spans '())) + (loop for segment in segments + for first-p = t then nil + do (unless first-p + (incf offset 3) + (incf x (funcall measure " | "))) + (when (>= offset prefix-length) (return)) + (let* ((text (%bar-string (head-bar-segment-text segment))) + (visible-length (min (length text) (- prefix-length offset))) + (end-x (+ x (funcall measure (subseq text 0 visible-length))))) + (when (and (> end-x x) (head-bar-segment-click-action segment)) + (push (list x end-x segment) spans)) + (incf offset (length text)) + (setf x end-x))) + (nreverse spans))) + +(defun %head-bar-height (backend head) + (%head-bar-reserved-height backend head)) + +(defun %free-head-bar (bar) + (when bar + (dolist (gcontext (list (x11-head-bar-background-gcontext bar) + (x11-head-bar-foreground-gcontext bar) + (x11-head-bar-inverse-foreground-gcontext bar))) + (when gcontext + (xlib:free-gcontext gcontext))) + (when (x11-head-bar-font bar) + (%free-text-font (x11-head-bar-font bar))) + (%free-ui-canvas (x11-head-bar-canvas bar)) + (maphash (lambda (color pixel) + (declare (ignore color)) + (xlib:free-colors (x11-head-bar-colormap bar) (list pixel))) + (x11-head-bar-colors bar)) + (when (x11-head-bar-window bar) + (xlib:destroy-window (x11-head-bar-window bar))))) + +(defun %make-head-bar (backend head) + "Create the one override-redirect X11 window owned by HEAD's bar." + (let* ((screen (x11-backend-x-screen backend)) + (height (%head-bar-height backend head)) + (window (xlib:create-window + :parent (x11-backend-root backend) + :x (x11-head-x head) :y (x11-head-y head) + :width (x11-head-width head) :height height + :background (xlib:screen-black-pixel screen) + :border-width 0 + :override-redirect :on + :event-mask '(:exposure :button-press :pointer-motion :enter-window :leave-window))) + (black (xlib:screen-black-pixel screen)) + (white (xlib:screen-white-pixel screen))) + (make-x11-head-bar + :head-id (x11-head-head-id head) + :window window :height height + :colormap (xlib:screen-default-colormap screen) + :background-gcontext (xlib:create-gcontext :drawable window + :foreground black :background white) + :foreground-gcontext (xlib:create-gcontext :drawable window + :foreground white :background black) + :inverse-foreground-gcontext (xlib:create-gcontext :drawable window + :foreground black :background white)))) + +(defun %configure-head-bar (backend bar head) + "Move and resize BAR when its physical Head rectangle changes." + (let ((height (%head-bar-height backend head)) + (window (x11-head-bar-window bar))) + (xlib:with-state (window) + (setf (xlib:drawable-x window) (x11-head-x head) + (xlib:drawable-y window) (x11-head-y head) + (xlib:drawable-width window) (x11-head-width head) + (xlib:drawable-height window) height)) + (setf (x11-head-bar-height bar) height) + bar)) + +(defun %head-bar-for-window (backend window) + (let ((window-id (xlib:window-id window))) + (loop for head-id in (x11-backend-head-ids backend) + for bar = (gethash head-id (x11-backend-head-bars backend)) + when (and bar + (= window-id (xlib:window-id (x11-head-bar-window bar)))) + return bar))) + +(defun %head-bar-visible-p (backend head-id) + "A genuine fullscreen client owns its physical Head, including the bar." + (null (ewmh-fullscreen-client-id-for-head backend head-id))) + +(declaim (ftype function backend-activity-slot)) + +(defun %bar-presentation-label (backend head-id) + (let* ((world (x11-backend-world backend)) + (presentation (current-presentation world head-id))) + (if (null presentation) + "No activity" + (handler-case + (activity-name (find-activity world (presentation-activity-id presentation))) + (unknown-entity () "Activity"))))) + +(defun %bar-activity-entries (backend head-id) + "Slot-ordered Activity names; highlight where this Head is working. + +Saved Views are recallable arrangements, not nested workspace locations." + (let* ((world (x11-backend-world backend)) + (p (current-presentation world head-id)) + (active-id (and p (presentation-activity-id p)))) + (mapcar (lambda (activity) + (let* ((id (activity-id activity)) (active-p (equal id active-id))) + (list :id id :active-p active-p + :text (%single-line-text (activity-name activity))))) + (sort (list-activities world) #'< + :key (lambda (a) (backend-activity-slot backend (activity-id a))))))) + +(defun %fit-bar-activities (entries maximum-width measure fit) + "Fit separate shaped tabs, keeping the active one and a clickable overflow. + +Inactive tabs fit whole; the active tab may be grapheme-truncated. When space +is scarce, keep its nearest slot neighbors in order, with omitted tabs in the +overflow picker. Runs are the sole source of painting and hit-test geometry." + (let* ((gap (max 8 (funcall measure " "))) + (rows (loop for entry in entries for index from 0 + collect (list :entry entry :index index :text (getf entry :text) + :width (funcall measure (getf entry :text))))) + (total (+ (reduce #'+ rows :key (lambda (r) (getf r :width)) :initial-value 0) + (* gap (max 0 (1- (length rows)))))) + (selected rows) (overflow nil)) + (when (> total maximum-width) + (let* ((anchor (or (find-if (lambda (r) (getf (getf r :entry) :active-p)) rows) (first rows))) + (more (funcall fit "…" maximum-width measure)) + (more-width (funcall measure more)) + (budget (max 0 (- maximum-width more-width gap))) + (text (and anchor (funcall fit (getf anchor :text) budget measure))) + (used (if text (funcall measure text) 0))) + (setf selected nil) + (when (plusp used) + (let ((fitted (copy-list anchor))) + (setf (getf fitted :text) text (getf fitted :width) used) + (push fitted selected)) + (dolist (row (stable-sort (remove anchor (copy-list rows)) #'< + :key (lambda (r) (abs (- (getf r :index) (getf anchor :index)))))) + (when (<= (+ used gap (getf row :width)) budget) + (incf used (+ gap (getf row :width))) + (push row selected)))) + (setf selected (sort selected #'< :key (lambda (r) (getf r :index)))) + (when (plusp more-width) + (setf overflow (list :text more :width more-width :overflow-p t))))) + (let ((x 0) (runs nil)) + (dolist (row (append selected (when overflow (list overflow)))) + (when runs (incf x gap)) + (push (list :x x :width (getf row :width) :text (getf row :text) + :entry (getf row :entry) :overflow-p (getf row :overflow-p)) runs) + (incf x (getf row :width))) + (values "" 0 x (nreverse runs))))) + +(defun %bar-open-activity (backend head-id activity-id) + "A tab click uses the same resume/no-op/lease choices as number keys." + (backend-select-head backend head-id) + (%show-navigation-result backend (%ui-request-activity-activation backend activity-id))) + +(defun %bar-monocle-client-count (world presentation) + "Count all leased tiles in monocle, including the currently visible one. + +Floats, explicitly hidden Activity clients, and tiles leased elsewhere are +not part of this Head's monocle stack." + (let ((leased-client-ids (presentation-leased-client-ids world presentation))) + (count-if (lambda (placement) + (and (eq (placement-kind placement) :tile) + (member (placement-client-id placement) + leased-client-ids :test #'equal))) + (presentation-placements presentation)))) + +(defun %bar-layout-token (backend head-id) + "Render the compact layout vocabulary used by Lime's initial bar. + +There is no all-floating layout today. `><>` therefore remains reserved for +a future explicit layout policy; individual floated clients continue to show +the View's underlying tiled policy here." + (let* ((world (x11-backend-world backend)) + (presentation (current-presentation world head-id))) + (if (null presentation) + "" + (case (presentation-layout-mode presentation) + (:master-stack "[]=") + (:manual "|M|") + (:monocle (format nil "[~D]" + (%bar-monocle-client-count world presentation))) + (otherwise "|M|"))))) + +(defun %bar-focused-client-id (backend head-id) + (or (ewmh-fullscreen-client-id-for-head backend head-id) + (let ((presentation (current-presentation (x11-backend-world backend) + head-id))) + (and presentation (presentation-focus-client-id presentation))))) + +(defun %bar-focused-title (backend head-id) + (let ((client-id (%bar-focused-client-id backend head-id))) + (cond + ((null client-id) "") + (t + (let ((info (backend-client-icccm-info backend client-id))) + (or (and info (%nonempty-title (icccm-client-info-title info))) + (and info (%nonempty-title (icccm-client-info-resource-class info))) + (and info (%nonempty-title (icccm-client-info-resource-name info))) + "Untitled window")))))) + +(defun %provider-segments (backend head-id) + "Collect valid segments while keeping one status module failure non-fatal." + (loop for provider in (x11-backend-head-bar-status-providers backend) + append + (handler-case + (let ((result (if (functionp provider) + (funcall provider backend head-id) + (%managed-provider-segment backend provider)))) + (cond + ((null result) '()) + ((typep result 'head-bar-segment) (list (%validate-head-bar-segment result))) + ((listp result) + (mapcar #'%validate-head-bar-segment + (remove-if-not (lambda (segment) + (typep segment 'head-bar-segment)) + result))) + (t '()))) + (error (condition) + (setf (x11-backend-last-command-error backend) condition) + '())))) + +(defun %bar-status-string (segments) + (format nil "~{~A~^ | ~}" (mapcar #'head-bar-segment-text segments))) + +(defun %bar-attention-segment (backend) + "Global count on every Head: parked Activities must still be discoverable." + (let* ((style (%head-bar-style backend)) + (count (length (backend-attention-client-ids backend)))) + (when (and (head-bar-style-attention-indicator-p style) (plusp count)) + (make-head-bar-segment + :id :attention + :text (format nil "~A ~D" (head-bar-style-attention-marker style) count) + :foreground (head-bar-style-attention-color style) + :click-action (lambda (clicked-backend head-id) + (backend-focus-head-background clicked-backend head-id) + (backend-open-attention-picker clicked-backend)))))) + +(defun %fit-bar-status (font segments maximum-width) + "Shape each provider separately: RTL text must not reorder neighboring widgets." + (let ((runs '()) (x 0) (prefix 0) (first-p t)) + (block fit + (dolist (segment segments) + (let ((text (%single-line-text (head-bar-segment-text segment)))) + (when (plusp (length text)) + (dolist (token (append (unless first-p (list (cons nil " | "))) + (list (cons segment text)))) + (let* ((remaining (- maximum-width x)) + (cap (and (car token) (head-bar-segment-maximum-width (car token)))) + (budget (if (and (integerp cap) (plusp cap)) (min remaining cap) remaining))) + (multiple-value-bind (visible retained) + (%fit-ui-text font (cdr token) budget) + (let ((width (%text-width font visible))) + (when (plusp width) + (push (list :x x :text visible :width width :prefix retained + :segment (car token)) runs)) + (incf x width) + (incf prefix retained) + ;; A deliberately capped song must leave space for volume + ;; and clock; exhausted whole-bar space still ends the run. + (when (and (< retained (length (cdr token))) (>= budget remaining)) + (return-from fit nil)))))) + (setf first-p nil))))) + (values "" prefix x (nreverse runs)))) + +(defun %draw-head-bar (backend bar) + "Render a complete Unicode frame and derive click regions from shaped text." + (let* ((head-id (x11-head-bar-head-id bar)) + (window (x11-head-bar-window bar)) + (font (setf (x11-head-bar-font bar) + (%ensure-text-font (x11-head-bar-font bar) (%configured-font backend)))) + (measure (lambda (text) (%text-width font text))) + (fit (lambda (text width ignored) (declare (ignore ignored)) + (%fit-ui-text font text width))) + (width (xlib:drawable-width window)) + (height (x11-head-bar-height bar)) + (canvas (setf (x11-head-bar-canvas bar) + (%ensure-ui-canvas (x11-head-bar-canvas bar) width height))) + (style (%head-bar-style backend)) + (baseline (%font-centered-baseline font height)) + (focused-p (equal head-id (x11-backend-focused-head-id backend))) + ;; First claim on status space so a long song cannot hide the alert. + (segments (append (let ((attention (%bar-attention-segment backend))) + (when attention (list attention))) + (%provider-segments backend head-id))) + (activities (%bar-activity-entries backend head-id)) + (layout (%bar-text-layout + width (%bar-presentation-label backend head-id) + (%bar-layout-token backend head-id) (%bar-focused-title backend head-id) + "" measure :padding-x (head-bar-style-padding-x style) :fit fit + :minimum-label-width (if activities 96 0) + :label-fit (lambda (label budget ignored) + (declare (ignore label ignored)) + (%fit-bar-activities activities budget measure fit)) + :status-fit (lambda (ignored budget ignored-measure) + (declare (ignore ignored ignored-measure)) + (%fit-bar-status font segments budget)))) + (foreground (head-bar-style-foreground style)) + (separator (head-bar-style-separator-color style)) + (title-left (getf layout :title-left)) + (title-right (getf layout :title-right)) + (regions '())) + (%canvas-rectangle canvas 0 0 width height (head-bar-style-background style)) + (flet ((draw (text x color &optional (limit (funcall measure text))) + (%canvas-text canvas font text x 0 limit height color :baseline baseline))) + (draw (getf layout :logo) (getf layout :logo-x) + (or (head-bar-style-logo-color style) foreground)) + (push (make-x11-head-bar-hit-region + :left 0 :right (getf layout :logo-width) + :action (lambda (clicked-backend clicked-head-id) + (backend-select-head clicked-backend clicked-head-id) + (backend-open-command-palette clicked-backend))) regions) + (dolist (run (getf layout :label-runs)) + (let* ((entry (getf run :entry)) (id (getf entry :id)) + (x (+ (getf layout :label-x) (getf run :x)))) + (draw (getf run :text) x + (cond ((getf run :overflow-p) separator) + ((getf entry :active-p) (%ui-accent-color style)) + (t foreground)) + (getf run :width)) + (push (make-x11-head-bar-hit-region + :left x :right (+ x (getf run :width)) + :action (if (getf run :overflow-p) + (lambda (b head) + (backend-select-head b head) + (backend-open-activity-picker b)) + (lambda (b head) (%bar-open-activity b head id)))) regions))) + (let ((token (getf layout :layout-token)) (x (getf layout :layout-x))) + (when (plusp (length token)) + (draw token x foreground) + (push (make-x11-head-bar-hit-region + :left x :right (+ x (funcall measure token)) + :action (lambda (clicked-backend clicked-head-id) + (backend-cycle-layout clicked-backend :head-id clicked-head-id))) regions))) + (%canvas-rectangle canvas title-left 0 (- title-right title-left) height + (if focused-p (head-bar-style-focused-background style) + (head-bar-style-unfocused-background style))) + (when (and (> title-right title-left) (head-bar-style-title-edge-color style)) + (dolist (x (remove-duplicates (list title-left (1- title-right)))) + (%canvas-rectangle canvas x 0 1 height (head-bar-style-title-edge-color style)))) + (draw (getf layout :title) (getf layout :title-x) + (if focused-p (head-bar-style-focused-foreground style) + (head-bar-style-unfocused-foreground style)) + (getf layout :title-width)) + (dolist (span (getf layout :separators)) (draw (cdr span) (car span) separator)) + (dolist (run (getf layout :status-runs)) + (let* ((text (getf run :text)) + (x (+ (getf layout :status-x) (getf run :x))) + (segment (getf run :segment))) + (%canvas-text canvas font text x 0 (getf run :width) height + (if segment (or (head-bar-segment-foreground segment) foreground) separator) + :baseline baseline + :prefix-length (if segment + (min (getf run :prefix) (head-bar-segment-prefix-length segment)) + 0) + :prefix-color (and segment (head-bar-segment-prefix-foreground segment))) + (when (and segment (head-bar-segment-click-action segment)) + (dolist (range (%text-prefix-ranges font text (getf run :prefix))) + (when (> (cdr range) (car range)) + (push (make-x11-head-bar-hit-region + :left (+ x (car range)) :right (+ x (cdr range)) + :action (head-bar-segment-click-action segment)) regions))))))) + (%prune-head-bar-colors bar style) + (%present-ui-canvas backend canvas window (x11-head-bar-foreground-gcontext bar)) + (setf (x11-head-bar-hit-regions bar) (nreverse regions)) + (xlib:map-window window) + (setf (xlib:window-priority window) :above) + ;; Status/geometry changes can alter clickability without pointer motion. + (let ((point (%ui-window-pointer-position backend window))) + (%update-head-bar-pointer backend bar + (and point (%head-bar-hit-at bar (car point) (cdr point))))) + bar)) + +(defun render-head-bars (backend) + "Redraw and raise every visible Head bar after a model or focus change." + (when (x11-backend-display backend) + (dolist (head-id (x11-backend-head-ids backend)) + (let ((bar (gethash head-id (x11-backend-head-bars backend)))) + (when bar + (if (%head-bar-visible-p backend head-id) + (%draw-head-bar backend bar) + (xlib:unmap-window (x11-head-bar-window bar)))))) + (xlib:display-force-output (x11-backend-display backend))) + backend) + +(defun reconcile-head-bars (backend) + "Make the adapter-owned bar set match the currently configured Head set." + (let ((bars (x11-backend-head-bars backend)) + (head-ids (x11-backend-head-ids backend))) + (maphash (lambda (head-id bar) + (unless (member head-id head-ids :test #'equal) + (%free-head-bar bar) + (remhash head-id bars))) + bars) + (dolist (head-id head-ids) + (let* ((head (%head-for-id backend head-id)) + (height (%head-bar-height backend head)) + (existing (gethash head-id bars))) + (cond + ((zerop height) + (when existing + (%free-head-bar existing) + (remhash head-id bars))) + (existing + (%configure-head-bar backend existing head)) + (t + (setf (gethash head-id bars) (%make-head-bar backend head))))))) + (render-head-bars backend)) + +(defun initialize-head-bars (backend) + "Create Lime's persistent bar windows for the backend's initial Heads." + (reconcile-head-bars backend)) + +(defun shutdown-head-bars (backend) + "Free every adapter-owned Head bar while the CLX display is still open." + (maphash (lambda (head-id bar) + (declare (ignore head-id)) + (%free-head-bar bar)) + (x11-backend-head-bars backend)) + (clrhash (x11-backend-head-bars backend)) + backend) + +(defun backend-set-head-bar-height (backend height) + "Set a non-negative top-bar reservation and immediately reflow clients." + (unless (and (integerp height) (not (minusp height))) + (error 'invalid-transition + :description "A Head bar height must be a non-negative integer.")) + (setf (x11-backend-head-bar-height backend) height) + (reconcile-head-bars backend) + (apply-active-presentation backend) + backend) + +(defun backend-set-head-bar-status-providers (backend providers) + "Install right-side status PROVIDERS and redraw without changing model state. + +Providers may be fast functions of (BACKEND HEAD-ID), returning segments, +or managed STATUS-PROVIDER objects whose I/O runs outside the X event thread." + (%validate-status-providers providers) + (%reconcile-status-providers backend providers) + (setf (x11-backend-head-bar-status-providers backend) (copy-list providers)) + (render-head-bars backend)) + +(defun %handle-head-bar-exposure (backend window count) + "Redraw an exposed bar and return true exactly when WINDOW belongs to Lime." + (let ((bar (%head-bar-for-window backend window))) + (when (and bar (zerop count)) + (when (%head-bar-visible-p backend (x11-head-bar-head-id bar)) + (%draw-head-bar backend bar)) + (xlib:display-force-output (x11-backend-display backend))) + (not (null bar)))) + +(defun %head-bar-hit-at (bar x y) + "The same measured regions drive both the hand cursor and click dispatch." + (when (<= 0 y (1- (x11-head-bar-height bar))) + (find-if (lambda (region) + (and (x11-head-bar-hit-region-action region) + (<= (x11-head-bar-hit-region-left region) x) + (< x (x11-head-bar-hit-region-right region)))) + (x11-head-bar-hit-regions bar)))) + +(defun %update-head-bar-pointer (backend bar hit) + (setf (x11-head-bar-pointer-hand-p bar) + (%set-ui-pointer backend (x11-head-bar-window bar) hit (x11-head-bar-pointer-hand-p bar)))) + +(defun %handle-head-bar-motion (backend window root-x root-y) + (let ((bar (%head-bar-for-window backend window))) + (when bar + (%update-head-bar-pointer backend bar + (%head-bar-hit-at bar (- root-x (xlib:drawable-x window)) + (- root-y (xlib:drawable-y window)))) + t))) + +(defun %handle-head-bar-leave (backend window) + (let ((bar (%head-bar-for-window backend window))) + (when bar (%update-head-bar-pointer backend bar nil)))) + +(defun %handle-head-bar-button-press (backend window root-x root-y button state time) + "Route a Head-bar click without allowing the pointer layer to see it." + (declare (ignore state time)) + (let ((bar (%head-bar-for-window backend window))) + (when bar + (let* ((head-id (x11-head-bar-head-id bar)) + (head (%head-for-id backend head-id)) + (local-x (- root-x (x11-head-x head)))) + ;; A bar click makes its Head the command target even if it lands on + ;; inert text. This mirrors a background click without changing View + ;; contents or stealing the saved client focus target. + (when (= button 1) + (backend-focus-head-background backend head-id) + (let ((region (%head-bar-hit-at bar local-x (- root-y (x11-head-y head))))) + (when region + (funcall (x11-head-bar-hit-region-action region) backend head-id)))) + t)))) diff --git a/src/x11/commands.lisp b/src/x11/commands.lisp new file mode 100644 index 0000000..a243a22 --- /dev/null +++ b/src/x11/commands.lisp @@ -0,0 +1,1061 @@ +(in-package #:lime.x11) + +(declaim (ftype function backend-switch-to-activity backend-preflight-activity-switch + %portable-activity-presentation %portable-view-preview-world)) + +;;;; Frontend-neutral command layer +;;; +;;; This file is deliberately between the pure Lime model and an eventual +;;; keybinding, menu, or IPC frontend. Each command chooses a tested model +;;; transition, then renders all affected Heads through the X11 backend. + +(defun %current-presentation-or-error (backend &optional head-id) + (or (current-presentation (x11-backend-world backend) + (or head-id (x11-backend-focused-head-id backend))) + (error 'invalid-transition + :description "The X11 Head has no active Presentation."))) + +(defun %apply-command-result (backend presentation) + (when (equal (presentation-head-id presentation) + (x11-backend-focused-head-id backend)) + (setf (x11-backend-activity-id backend) + (presentation-activity-id presentation) + (x11-backend-focus-root-override-p backend) nil)) + (apply-active-presentation backend) + presentation) + +(defun %activate-view-with-policy (world head-id view-id policy) + (ecase policy + (:strict (activate-view-strictly world head-id view-id)) + (:partial (activate-view-partially world head-id view-id)) + (:take (activate-view-taking world head-id view-id)))) + +(defun %resume-presentation-with-policy (world head-id presentation-id policy) + (ecase policy + (:strict (resume-presentation-strictly world head-id presentation-id)) + (:partial (resume-presentation-partially world head-id presentation-id)) + (:take (resume-presentation-taking world head-id presentation-id)))) + +(defun %activate-viewset-with-policy (world viewset-id policy) + (ecase policy + (:strict (activate-viewset-strictly world viewset-id)) + (:partial (activate-viewset-partially world viewset-id)) + (:take (activate-viewset-taking world viewset-id)))) + +(defun %apply-viewset-result (backend result) + "Synchronize adapter-local command focus after an atomic Viewset commit." + (let ((presentation (current-presentation + (x11-backend-world backend) + (x11-backend-focused-head-id backend)))) + (setf (x11-backend-activity-id backend) + (and presentation (presentation-activity-id presentation)) + (x11-backend-focus-root-override-p backend) nil) + (apply-active-presentation backend) + result)) + +(defun backend-head-ids (backend) + "Return configured Head ids in their rendering order." + (copy-list (x11-backend-head-ids backend))) + +(defun backend-select-head (backend head-id) + "Select HEAD-ID for REPL commands, MapRequest routing, and X input focus." + (%head-for-id backend head-id) + (let ((presentation (current-presentation (x11-backend-world backend) head-id))) + (setf (x11-backend-focused-head-id backend) head-id + (x11-backend-activity-id backend) + (and presentation (presentation-activity-id presentation)) + (x11-backend-focus-root-override-p backend) nil) + ;; A newly discovered Head may deliberately be blank. The renderer makes + ;; its saved focus target real when present, otherwise focuses root so the + ;; palette can start or mount an Activity there. + (apply-active-presentation backend) + (backend-status backend))) + +(defun %relative-head-id (backend head-id direction) + "Return the configured Head adjacent to HEAD-ID, wrapping at either end." + (let* ((head-ids (x11-backend-head-ids backend)) + (position (position head-id head-ids :test #'equal))) + (unless position + (error 'invalid-transition + :description (format nil "Head ~S is not configured." head-id))) + (when (< (length head-ids) 2) + (error 'invalid-transition + :description "This command needs at least two configured Heads.")) + (elt head-ids + (mod (+ position (ecase direction + (:next 1) + (:previous -1))) + (length head-ids))))) + +(defun backend-select-relative-head + (backend direction &key (head-id (x11-backend-focused-head-id backend))) + "Select the next or previous configured Head, wrapping around the list." + (backend-select-head backend (%relative-head-id backend head-id direction))) + +(defun backend-status (backend &key (head-id (x11-backend-focused-head-id backend))) + "Return a compact, REPL-friendly snapshot of one configured Head." + (%head-for-id backend head-id) + (let ((presentation (current-presentation (x11-backend-world backend) head-id)) + (world (x11-backend-world backend))) + (list :session (backend-session-status backend) + :head-id head-id + :blank-p (null presentation) + :activity-id (and presentation (presentation-activity-id presentation)) + :presentation-id (and presentation (presentation-id presentation)) + :source-view-id (and presentation (presentation-source-view-id presentation)) + :layout-mode (and presentation (presentation-layout-mode presentation)) + :layout-options (and presentation + (copy-tree (presentation-layout-options presentation))) + :dirty-p (and presentation (presentation-dirty-p presentation)) + :focus-client-id (and presentation (presentation-focus-client-id presentation)) + :fullscreen-client-id (ewmh-fullscreen-client-id-for-head backend head-id) + :client-ids (and presentation (presentation-client-ids presentation)) + :floating-client-ids + (loop for placement in (and presentation + (presentation-placements presentation)) + when (eq (placement-kind placement) :float) + collect (placement-client-id placement)) + :hidden-client-ids + (and presentation (presentation-hidden-client-ids world presentation)) + :leased-client-ids (and presentation + (presentation-leased-client-ids world presentation)) + :unavailable-client-ids + (and presentation (presentation-unavailable-client-ids presentation))))) + +(defun %showable-client-ids (world presentation) + "Parked home/shared clients, including requested slots taken by another Head." + (remove-duplicates + (append (presentation-hidden-client-ids world presentation) + (copy-list (presentation-unavailable-client-ids presentation))) + :test #'equal)) + +(defun %require-hidden-activity-client (world presentation client-id) + "Validate that CLIENT-ID is an eligible, not already leased local client." + (unless (member client-id (%showable-client-ids world presentation) + :test #'equal) + (error 'invalid-transition + :description "The client is not hidden in this presentation.")) + client-id) + +(defun %require-visible-client (backend client-id head-id) + (let* ((world (x11-backend-world backend)) + (presentation (%current-presentation-or-error backend head-id))) + (unless (member client-id (presentation-leased-client-ids world presentation) :test #'equal) + (error 'invalid-transition :description "That window is no longer visible on this Head.")) + presentation)) + +(defun %membership-focus-policy (backend) + (lambda (container) + (configured-close-focus-direction + backend (etypecase container + (view (view-layout-mode container)) + (presentation (presentation-layout-mode container)))))) + +(defun backend-move-client-to-activity + (backend client-id activity-id &key (head-id (x11-backend-focused-head-id backend))) + "Send a window to the destination's portable arrangement or local portion." + (let* ((source (%require-visible-client backend client-id head-id)) + (world (x11-backend-world backend)) + (target (or (%portable-activity-presentation backend activity-id) + (activity-draft-for-head world activity-id head-id))) + (layout (if target (presentation-layout-mode target) (configured-default-layout backend)))) + (when (equal activity-id (presentation-activity-id source)) + (error 'invalid-transition :description "Choose a different Activity.")) + (let ((position (configured-new-tiled-client-position backend layout)) + (direction (%membership-focus-policy backend))) + (if (and target (presentation-active-p world target)) + (move-client-to-presentation world client-id (presentation-id target) + :tiled-insertion-position position :focus-direction direction) + (move-client-to-activity world client-id activity-id + :target-presentation-id (and target (presentation-id target)) + :target-head-id (unless target head-id) :default-layout layout + :tiled-insertion-position position :focus-direction direction))) + (%apply-command-result backend source))) + +(defun backend-make-client-private + (backend client-id &key (head-id (x11-backend-focused-head-id backend)) expected-revision) + "Keep CLIENT-ID private to its current Activity, preserving placement and focus. + +This non-prompting command requires a visible lease on HEAD-ID. Interactive +callers confirm the named Activity first and supply EXPECTED-REVISION." + (let ((world (x11-backend-world backend))) + (when (and expected-revision (/= expected-revision (world-revision world))) + (error 'stale-transition-plan)) + (let ((presentation (%require-visible-client backend client-id head-id))) + (make-client-private-in-presentation + world client-id (presentation-id presentation) + :expected-revision expected-revision :focus-direction (%membership-focus-policy backend)) + (apply-active-presentation backend) + (find-client world client-id)))) + +(defun backend-set-client-shared (backend client-id shared-p) + "Share without moving; making private keeps the window on the current Head." + (if (null shared-p) + (backend-make-client-private backend client-id) + (progn + (set-client-shared (x11-backend-world backend) client-id shared-p + :focus-direction (%membership-focus-policy backend)) + (apply-active-presentation backend) + (find-client (x11-backend-world backend) client-id)))) + +(defun backend-hide-client (backend client-id + &key (head-id (x11-backend-focused-head-id backend))) + "Hide CLIENT-ID from HEAD-ID's live draft without closing or minimizing it." + (%head-for-id backend head-id) + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (hide-client-from-presentation (x11-backend-world backend) + client-id (presentation-id presentation) + :focus-direction + (configured-close-focus-direction + backend + (presentation-layout-mode presentation)))))) + +(defun backend-hide-focused-client + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Hide HEAD-ID's focused visible client from its current live draft." + (%head-for-id backend head-id) + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (hide-focused-client-in-presentation (x11-backend-world backend) + (presentation-id presentation) + :focus-direction + (configured-close-focus-direction + backend + (presentation-layout-mode presentation)))))) + +(defun backend-show-client (backend client-id + &key (head-id (x11-backend-focused-head-id backend)) + (kind :tile) data) + "Reveal an available hidden Activity client on HEAD-ID and focus it. + +If another Head has the client leased, this function makes no mutation and +asks the caller to use `BACKEND-SHOW-CLIENT-TAKING` explicitly. This keeps a +plain show action from unexpectedly stealing a real window from another +visible View." + (%head-for-id backend head-id) + (let* ((world (x11-backend-world backend)) + (presentation (%current-presentation-or-error backend head-id)) + (lease (lease-for-client world client-id))) + (%require-hidden-activity-client world presentation client-id) + (when lease + (error 'invalid-transition + :description + (format nil "Client ~S is visible on Head ~S; move it here explicitly." + client-id + (presentation-head-id + (find-presentation world (lease-presentation-id lease)))))) + (show-client-on-presentation world client-id (presentation-id presentation) + :kind kind :data data) + ;; Focusing through the normal command keeps input routing and rendering + ;; consistent even when a REPL/IPC caller targeted a non-focused Head. + (backend-focus-client backend client-id :head-id head-id))) + +(defun backend-show-client-taking + (backend client-id + &key (head-id (x11-backend-focused-head-id backend)) kind data) + "Reveal CLIENT-ID on HEAD-ID, explicitly transferring a conflicting lease. + +When the source presentation has the client as a float, its float kind and +geometry are retained by default. A caller may pass KIND or DATA to choose a +different destination presentation instead." + (%head-for-id backend head-id) + (let* ((world (x11-backend-world backend)) + (target (%current-presentation-or-error backend head-id)) + (lease (lease-for-client world client-id))) + (%require-hidden-activity-client world target client-id) + (let* ((source (and lease + (find-presentation world (lease-presentation-id lease)))) + (source-placement + (and source + (%placement-for-client source client-id))) + (destination-kind (or kind + (and source-placement + (placement-kind source-placement)) + :tile)) + (destination-data (or data + (and source-placement + (copy-tree (placement-data source-placement)))))) + (show-client-on-presentation world client-id (presentation-id target) + :kind destination-kind :data destination-data) + (when (and lease + (not (equal (lease-presentation-id lease) + (presentation-id target)))) + (transfer-client-lease world client-id (presentation-id target)) + ;; The transfer core clears a departed focused target. Give the + ;; source its next surviving client when it has one, avoiding a stale + ;; focus preference without inventing focus on an empty Head. + (when source + (let ((next-client-id (first (presentation-leased-client-ids world source)))) + (when next-client-id + (focus-client-on-presentation world next-client-id + (presentation-id source)))))) + (backend-focus-client backend client-id :head-id head-id)))) + +(defun backend-request-quit (backend) + "Request a graceful Lime shutdown and return BACKEND. + +This deliberately does not close the CLX display from inside a key or palette +handler. The owner of RUN-EVENT-LOOP observes the request at its next loop +boundary, then STOP-BACKEND remaps managed clients, releases Lime's root +selection, and closes the connection cleanly. It therefore works equally for +the normal demo runner and the developer xinit runner." + (setf (x11-backend-quit-requested-p backend) t + (x11-backend-running-p backend) nil) + backend) + +(defun backend-delete-activity (backend activity-id &key expected-revision) + "Delete an empty, unmounted Activity without switching Heads or closing apps." + (let ((result (delete-activity (x11-backend-world backend) activity-id + :expected-revision expected-revision))) + (apply-active-presentation backend) + result)) + +(defun backend-start-activity (backend activity-id name + &key + (head-id (x11-backend-focused-head-id backend))) + "Create ACTIVITY-ID and open its blank unsaved draft on HEAD-ID. + +An Activity is usable before it has any saved View. Clients opened afterwards +join its live draft; saving a named View is the separate, explicit act of +capturing a checkpoint." + (let ((world (x11-backend-world backend))) + (%head-for-id backend head-id) + (create-activity world activity-id name) + (%apply-command-result backend + (open-activity-draft world head-id activity-id + :default-layout + (configured-default-layout backend))))) + +(defun %nonblank-command-name (name kind) + "Return a trimmed command-supplied NAME or signal a useful adapter error." + (unless (stringp name) + (error 'invalid-transition + :description (format nil "A ~A name must be a string." kind))) + (let ((trimmed (string-trim '(#\Space #\Tab #\Newline #\Return) name))) + (when (zerop (length trimmed)) + (error 'invalid-transition + :description (format nil "A ~A needs a non-empty name." kind))) + trimmed)) + +(defun %name-slug (name kind) + "Make a readable internal-id fragment from NAME without deciding uniqueness." + (let ((trimmed (%nonblank-command-name name kind))) + (let ((slug + (with-output-to-string (output) + (let ((wrote-character-p nil) + (pending-separator-p nil)) + (loop for character across trimmed + do (if (alphanumericp character) + (progn + (when (and wrote-character-p pending-separator-p) + (write-char #\- output)) + (write-char (char-downcase character) output) + (setf wrote-character-p t + pending-separator-p nil)) + (when wrote-character-p + (setf pending-separator-p t)))))))) + (when (zerop (length slug)) + (error 'invalid-transition + :description (format nil "A ~A name needs at least one letter or number." kind))) + slug))) + +(defun %fresh-id-from-name (world name kind finder &key prefix) + "Generate a readable, currently unused entity id for a human command name." + (let ((base (format nil "~@[~A/~]~A" prefix (%name-slug name kind)))) + (loop for suffix from 1 + for candidate = (if (= suffix 1) + base + (format nil "~A-~D" base suffix)) + when (handler-case + (progn (funcall finder world candidate) nil) + (unknown-entity () t)) + return candidate))) + +(defun backend-start-named-activity + (backend name &key (head-id (x11-backend-focused-head-id backend))) + "Create and mount a blank Activity whose durable id is derived from NAME. + +The human-facing name is preserved. Its machine id is a lowercase readable +slug, suffixed only when needed for uniqueness, so a palette or IPC client +does not need to invent ids before using the ordinary activity command." + (let* ((world (x11-backend-world backend)) + (activity-name (%nonblank-command-name name "Activity")) + (activity-id (%fresh-id-from-name world activity-name "Activity" + #'find-activity))) + (backend-start-activity backend activity-id activity-name :head-id head-id))) + +(defun backend-activate-activity (backend activity-id + &key + view-id + (head-id (x11-backend-focused-head-id backend)) + (policy :strict)) + "Open ACTIVITY-ID's live draft on HEAD-ID, or explicitly open VIEW-ID. + +Without VIEW-ID this brings its portable arrangement here or resumes an +extended Head-local portion, retaining dirty edits. An +explicit VIEW-ID asks to recall that checkpoint instead." + (let ((world (x11-backend-world backend))) + (find-activity world activity-id) + (if view-id + (progn + (let ((view (find-view world view-id))) + (unless (equal activity-id (view-activity-id view)) + (error 'invalid-transition + :description (format nil "View ~S does not belong to Activity ~S." + view-id activity-id)))) + (backend-activate-view backend view-id :head-id head-id :policy policy)) + (backend-switch-to-activity backend activity-id :head-id head-id :policy policy)))) + +(defun backend-preflight-activity-activation + (backend activity-id &key (head-id (x11-backend-focused-head-id backend))) + "Inspect opening ACTIVITY-ID's live draft on HEAD-ID without changing X11." + (%head-for-id backend head-id) + (backend-preflight-activity-switch backend activity-id :head-id head-id)) + +(defun backend-save-view (backend view-id name + &key (head-id (x11-backend-focused-head-id backend))) + "Save the active Presentation as a new named View without changing X11." + (let* ((world (x11-backend-world backend)) + (presentation (%current-presentation-or-error backend head-id))) + (save-view-from-presentation world view-id name (presentation-id presentation)))) + +(defun backend-save-named-view + (backend name &key (head-id (x11-backend-focused-head-id backend))) + "Checkpoint HEAD-ID's live draft under NAME and make that checkpoint current. + +The View id is derived from the active Activity id and NAME. Activating the +new checkpoint after saving is deliberate: subsequent `Update mounted View` +edits the checkpoint the user just named, rather than a previous source View." + (let* ((world (x11-backend-world backend)) + (presentation (%current-presentation-or-error backend head-id)) + (view-name (%nonblank-command-name name "View")) + (view-id (%fresh-id-from-name world view-name "View" #'find-view + :prefix (presentation-activity-id presentation)))) + (backend-save-view backend view-id view-name :head-id head-id) + (backend-activate-view-strictly backend view-id :head-id head-id))) + +(defun %viewset-entries-from-active-heads (backend head-ids) + "Capture selected Heads' mounted saved View ids, never mutable drafts." + (mapcar + (lambda (head-id) + (%head-for-id backend head-id) + (let ((presentation (%current-presentation-or-error backend head-id))) + (or (presentation-source-view-id presentation) + (error 'invalid-transition + :description + (format nil "Head ~S has an unsaved draft; save its View before capturing a Viewset." + head-id))) + (make-viewset-entry :head-id head-id + :view-id (presentation-source-view-id presentation)))) + head-ids)) + +(defun backend-save-viewset (backend viewset-id name &key head-ids) + "Save selected Heads' current saved Views as a named Viewset. + +HEAD-IDS defaults to every currently configured adapter Head in display order. +Every selected Head must be active and sourced from a saved View. This makes a +Viewset an honest shortcut to durable checkpoints rather than a hidden copy of +unsaved per-Head Presentation drafts." + (let ((selected-head-ids (or head-ids (x11-backend-head-ids backend)))) + (unless selected-head-ids + (error 'invalid-transition :description "A Viewset needs at least one Head.")) + (create-viewset (x11-backend-world backend) viewset-id name + (%viewset-entries-from-active-heads backend selected-head-ids)))) + +(defun backend-save-named-viewset (backend name &key head-ids) + "Capture selected Heads under a readable Viewset id derived from NAME." + (let* ((world (x11-backend-world backend)) + (viewset-name (%nonblank-command-name name "Viewset")) + (viewset-id (%fresh-id-from-name world viewset-name "Viewset" + #'find-viewset))) + (backend-save-viewset backend viewset-id viewset-name :head-ids head-ids))) + +(defun backend-update-view (backend view-id + &key (head-id (x11-backend-focused-head-id backend))) + "Explicitly overwrite VIEW-ID with the active Presentation's live draft." + (let* ((world (x11-backend-world backend)) + (presentation (%current-presentation-or-error backend head-id))) + (update-view-from-presentation world view-id (presentation-id presentation)))) + +(defun backend-update-current-view + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Explicitly update HEAD-ID's mounted saved View from its live draft. + +An unsourced Presentation has no checkpoint to overwrite, so this command +signals rather than guessing a View name." + (let ((presentation (%current-presentation-or-error backend head-id))) + (or (presentation-source-view-id presentation) + (error 'invalid-transition + :description "The active Presentation has no saved View to update.")) + (backend-update-view backend (presentation-source-view-id presentation) + :head-id head-id))) + +(defun backend-preflight-view-activation (backend view-id + &key + (head-id (x11-backend-focused-head-id backend))) + "Inspect mounting VIEW-ID on HEAD-ID without changing the model or X11. + +The returned ACTIVATION-REPORT is the UI-neutral collision data a menu, +keybinding, IPC client, or REPL uses to choose an explicit follow-up command." + (%head-for-id backend head-id) + (preflight-view-activation + (or (%portable-view-preview-world backend view-id head-id) (x11-backend-world backend)) + head-id view-id)) + +(defun backend-activate-view (backend view-id + &key + (head-id (x11-backend-focused-head-id backend)) + (policy :strict)) + "Mount VIEW-ID and apply it to X11. + +POLICY is one of :STRICT, :PARTIAL, or :TAKE, matching Lime's explicit lease +collision choices. A strict collision signals ACTIVATION-BLOCKED and leaves +the display untouched." + (%head-for-id backend head-id) + (let ((preview (%portable-view-preview-world backend view-id head-id))) + (when preview + ;; Check the entire compound operation before moving anything live. + (%activate-view-with-policy preview head-id view-id policy) + (let* ((world (x11-backend-world backend)) + (p (%portable-activity-presentation backend (view-activity-id (find-view world view-id))))) + (bring-presentation-to-head world (presentation-id p) head-id))) + (%apply-command-result backend (%activate-view-with-policy (x11-backend-world backend) head-id view-id policy)))) + +(defun backend-activate-view-strictly (backend view-id + &key + (head-id (x11-backend-focused-head-id backend))) + "Mount VIEW-ID only if preflight finds no collisions." + (backend-activate-view backend view-id :head-id head-id :policy :strict)) + +(defun backend-activate-view-partially (backend view-id + &key + (head-id (x11-backend-focused-head-id backend))) + "Mount VIEW-ID without taking windows leased on another Head." + (backend-activate-view backend view-id :head-id head-id :policy :partial)) + +(defun backend-activate-view-taking (backend view-id + &key + (head-id (x11-backend-focused-head-id backend))) + "Mount VIEW-ID and explicitly transfer any colliding window leases." + (backend-activate-view backend view-id :head-id head-id :policy :take)) + +(defun backend-preflight-viewset-activation (backend viewset-id) + "Inspect a whole-Head Viewset recall without changing the model or X11." + (preflight-viewset-activation (x11-backend-world backend) viewset-id)) + +(defun backend-activate-viewset (backend viewset-id &key (policy :strict)) + "Atomically recall VIEWSET-ID across all its saved target Heads. + +POLICY is :STRICT, :PARTIAL, or :TAKE. The core checks every selected Head at +once, so a legitimate left/right View swap does not briefly collide with its +own outgoing leases or mounted Views." + (%apply-viewset-result + backend + (%activate-viewset-with-policy (x11-backend-world backend) viewset-id policy))) + +(defun backend-activate-viewset-strictly (backend viewset-id) + "Recall VIEWSET-ID only when all Views and client leases are available." + (backend-activate-viewset backend viewset-id :policy :strict)) + +(defun backend-activate-viewset-partially (backend viewset-id) + "Recall VIEWSET-ID while leaving outside leased clients in place." + (backend-activate-viewset backend viewset-id :policy :partial)) + +(defun backend-activate-viewset-taking (backend viewset-id) + "Recall VIEWSET-ID and explicitly take any outside leased clients." + (backend-activate-viewset backend viewset-id :policy :take)) + +(defun backend-resume-presentation (backend presentation-id + &key + (head-id (x11-backend-focused-head-id backend)) + (policy :strict)) + "Resume a cached Head-local draft and apply it to X11." + (%apply-command-result + backend + (%resume-presentation-with-policy (x11-backend-world backend) + head-id + presentation-id + policy))) + +(defun backend-set-layout-root (backend layout-root + &key (head-id (x11-backend-focused-head-id backend))) + "Replace the active Presentation's tiling tree and immediately reconfigure it." + (let ((presentation (%current-presentation-or-error backend head-id))) + (set-presentation-layout-root (x11-backend-world backend) + (presentation-id presentation) + layout-root) + (apply-active-presentation backend) + presentation)) + +(defun backend-use-master-stack-layout + (backend &key (head-id (x11-backend-focused-head-id backend)) + (master-count 1) (master-ratio 3/5) + (orientation :horizontal)) + "Apply the built-in master/stack policy to HEAD-ID's live draft." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (set-presentation-master-stack-layout + (x11-backend-world backend) (presentation-id presentation) + :master-count master-count + :master-ratio master-ratio + :orientation orientation)))) + +(defun backend-use-monocle-layout + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Show only the focused tiled client on HEAD-ID, retaining its other leases." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (set-presentation-monocle-layout (x11-backend-world backend) + (presentation-id presentation))))) + +(defun backend-use-manual-layout + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Leave the current built-in layout policy for the draft's explicit tree." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (set-presentation-manual-layout (x11-backend-world backend) + (presentation-id presentation))))) + +(defun %master-stack-options-or-error (presentation) + (unless (eq (presentation-layout-mode presentation) :master-stack) + (error 'invalid-transition + :description "This command requires the master-stack layout.")) + (values (getf (presentation-layout-options presentation) :master-count) + (getf (presentation-layout-options presentation) :master-ratio) + (getf (presentation-layout-options presentation) :orientation))) + +(defun backend-adjust-master-stack-ratio + (backend delta &key (head-id (x11-backend-focused-head-id backend))) + "Add DELTA to HEAD-ID's master/stack divide, clamped to usable bounds." + (unless (and (realp delta) (not (zerop delta))) + (error 'invalid-transition + :description "A master/stack ratio adjustment must be non-zero.")) + (let ((presentation (%current-presentation-or-error backend head-id))) + (multiple-value-bind (master-count master-ratio orientation) + (%master-stack-options-or-error presentation) + (backend-use-master-stack-layout + backend :head-id head-id :master-count master-count + :master-ratio (max 1/20 (min 19/20 (+ master-ratio delta))) + :orientation orientation)))) + +(defun backend-adjust-master-stack-count + (backend delta &key (head-id (x11-backend-focused-head-id backend))) + "Add DELTA to HEAD-ID's master count, retaining at least one master client." + (unless (and (integerp delta) (not (zerop delta))) + (error 'invalid-transition + :description "A master/stack count adjustment must be a non-zero integer.")) + (let ((presentation (%current-presentation-or-error backend head-id))) + (multiple-value-bind (master-count master-ratio orientation) + (%master-stack-options-or-error presentation) + (backend-use-master-stack-layout + backend :head-id head-id :master-count (max 1 (+ master-count delta)) + :master-ratio master-ratio :orientation orientation)))) + +(defun %focused-weight-placement (backend head-id) + (let* ((presentation (%current-presentation-or-error backend head-id)) + (client-id (presentation-focus-client-id presentation)) + (placement (find client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal))) + (unless (and (eq (presentation-layout-mode presentation) :master-stack) + placement (eq (placement-kind placement) :tile)) + (error 'invalid-transition + :description "Select a tiled window in master-stack to adjust its column share.")) + (values presentation placement))) + +(defun backend-set-focused-tile-weight + (backend weight &key (head-id (x11-backend-focused-head-id backend))) + "Set the focused tile's relative column share; WEIGHT 1 resets its size." + (multiple-value-bind (presentation placement) + (%focused-weight-placement backend head-id) + (%apply-command-result + backend + (set-client-tile-weight (x11-backend-world backend) + (presentation-id presentation) + (placement-client-id placement) weight)))) + +(defun backend-adjust-focused-tile-weight + (backend delta &key (head-id (x11-backend-focused-head-id backend)) + (minimum-weight 1/4) (maximum-weight 4)) + "Grow or shrink the focused tile's share within its master/stack column. + +DELTA and bounds are command policy, so configurations may choose their own +step and limits. Positive DELTA grows the tile; the result is clamped." + (unless (and (realp delta) (not (zerop delta)) + (realp minimum-weight) (realp maximum-weight) + (< 0 minimum-weight) (<= minimum-weight maximum-weight)) + (error 'invalid-transition + :description "Tile weight adjustment needs a nonzero delta and ordered positive bounds.")) + (multiple-value-bind (presentation placement) + (%focused-weight-placement backend head-id) + (declare (ignore presentation)) + (backend-set-focused-tile-weight + backend (max minimum-weight + (min maximum-weight (+ (placement-tile-weight placement) delta))) + :head-id head-id))) + +(defun %next-cycle-layout (current direction) + "Choose an everyday layout; a retained manual draft can leave the cycle." + (let* ((modes '(:master-stack :monocle)) + (position (position current modes)) + (delta (ecase direction (:next 1) (:previous -1)))) + (elt modes (if position + (mod (+ position delta) (length modes)) + (if (eq direction :next) 0 (1- (length modes))))))) + +(defun backend-cycle-layout + (backend &key (head-id (x11-backend-focused-head-id backend)) + (direction :next)) + "Cycle HEAD-ID through master-stack and monocle. + +Lime has no global \"all clients float\" layout: floating remains a per-client +placement. Manual trees remain available through BACKEND-USE-MANUAL-LAYOUT +and saved Views, but are deliberately absent from everyday cycling." + (let* ((presentation (%current-presentation-or-error backend head-id)) + (target-mode (%next-cycle-layout (presentation-layout-mode presentation) + direction))) + (ecase target-mode + (:master-stack + ;; Match the user's existing dwm mfact default (0.55) when entering + ;; the built-in policy from a manual or monocle draft. + (backend-use-master-stack-layout backend :head-id head-id + :master-ratio 11/20)) + (:monocle (backend-use-monocle-layout backend :head-id head-id))))) + +(defun backend-promote-focused-client + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Make HEAD-ID's focused tiled client the first master/stack client." + (let ((presentation (%current-presentation-or-error backend head-id))) + (or (presentation-focus-client-id presentation) + (error 'invalid-transition + :description "The selected Head has no focused client to promote.")) + (%apply-command-result + backend + (promote-client-to-master (x11-backend-world backend) + (presentation-id presentation) + (presentation-focus-client-id presentation))))) + +(defun backend-focus-master-client + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Focus HEAD-ID's first visible tiled client. + +In master/stack this is the first master. In manual or monocle it is the +Presentation's primary tiled slot, making the command predictable without +pretending that every layout has a master area." + (let* ((presentation (%current-presentation-or-error backend head-id)) + (leased-client-ids (presentation-leased-client-ids + (x11-backend-world backend) presentation)) + (client-id + (loop for placement in (presentation-placements presentation) + for candidate = (placement-client-id placement) + when (and (eq (placement-kind placement) :tile) + (member candidate leased-client-ids :test #'equal)) + return candidate))) + (or client-id + (error 'invalid-transition + :description "The selected Head has no visible tiled client.")) + (backend-focus-client backend client-id :head-id head-id))) + +(defun backend-orient-focused-split + (backend orientation &key (head-id (x11-backend-focused-head-id backend))) + "Set the focused client's nearest split on HEAD-ID to ORIENTATION." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (set-focused-layout-split-orientation + (x11-backend-world backend) (presentation-id presentation) orientation)))) + +(defun backend-resize-focused-split + (backend delta &key (head-id (x11-backend-focused-head-id backend))) + "Adjust the focused client's nearest split ratio by DELTA." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (adjust-focused-layout-split-ratio + (x11-backend-world backend) (presentation-id presentation) delta)))) + +(defun backend-swap-focused-client + (backend &key (head-id (x11-backend-focused-head-id backend)) + (direction :next)) + "Swap the focused tiled client with a visible neighboring layout slot." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (swap-focused-layout-client (x11-backend-world backend) + (presentation-id presentation) + :direction direction)))) + +(defun backend-toggle-client-floating + (backend client-id &key (head-id (x11-backend-focused-head-id backend)) data) + "Toggle CLIENT-ID between tiled and floating in HEAD-ID's live draft. + +The command is deliberately client-addressable as well as focus-addressable: +menus, IPC, and future rules can reuse the same core operation. DATA is used +only when converting a tiled client into its initial normalized rectangle." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (toggle-client-floating (x11-backend-world backend) + (presentation-id presentation) + client-id :data data)))) + +(defun backend-toggle-focused-client-floating + (backend &key (head-id (x11-backend-focused-head-id backend)) data) + "Toggle HEAD-ID's focused client between tiled and floating." + (let ((presentation (%current-presentation-or-error backend head-id))) + (%apply-command-result + backend + (toggle-focused-client-floating (x11-backend-world backend) + (presentation-id presentation) + :data data)))) + +(defun backend-set-client-floating-geometry + (backend client-id + &key (head-id (x11-backend-focused-head-id backend)) + (x nil x-supplied-p) (y nil y-supplied-p) + (width nil width-supplied-p) (height nil height-supplied-p)) + "Set a float's normalized rectangle and reconcile only that client's geometry. + +Geometry alone changes neither focus, leases, stacking, nor other clients. +In particular, pointer motion must not redo the entire desktop's render pass." + (let* ((presentation (%current-presentation-or-error backend head-id)) + (dirty-before (presentation-dirty-p presentation))) + (apply #'set-client-floating-geometry + (x11-backend-world backend) (presentation-id presentation) client-id + (append (when x-supplied-p (list :x x)) + (when y-supplied-p (list :y y)) + (when width-supplied-p (list :width width)) + (when height-supplied-p (list :height height)))) + (apply-floating-client-geometry backend presentation client-id) + ;; Only the first edit of a clean checkpoint changes the bar's dirty mark. + (unless dirty-before (render-head-bars backend)) + presentation)) + +(defun backend-focus-client (backend client-id + &key (head-id (x11-backend-focused-head-id backend))) + "Focus one visible client and make its Head the input-routing target. + +The core command rejects a parked, hidden, or cross-Head client before any +X11 request is made. Selecting the Head only after that validation keeps a +failed focus request free of incidental routing changes." + (%head-for-id backend head-id) + (let ((presentation (%current-presentation-or-error backend head-id))) + (focus-client-on-presentation (x11-backend-world backend) + client-id + (presentation-id presentation)) + (setf (x11-backend-focused-head-id backend) head-id + (x11-backend-activity-id backend) + (presentation-activity-id presentation) + (x11-backend-focus-root-override-p backend) nil) + (apply-active-presentation backend) + presentation)) + +(defun backend-attend-client (backend client-id &key (policy :strict)) + "Visit CLIENT-ID in its Activity, focusing it on its existing Head if leased. + +A hidden target resumes its Activity arrangement on the selected Head. POLICY +is retained for API compatibility, not a license to pull an already leased +target away from another Head. Saved Views +are never rewritten. This is a user command, never an application request." + (let* ((world (x11-backend-world backend)) + (activity-id (client-activity-id (find-client world client-id))) + (head-id (or (ewmh-active-head-id-for-client backend client-id) + (x11-backend-focused-head-id backend))) + (presentation (current-presentation world head-id))) + (unless (and presentation + (client-available-in-activity-p world client-id (presentation-activity-id presentation))) + (backend-activate-activity backend activity-id :head-id head-id :policy policy) + (setf presentation (current-presentation world head-id))) + ;; A different fullscreen window would otherwise mask this explicit visit. + (let ((fullscreen (ewmh-fullscreen-client-id-for-head backend head-id))) + (when (and fullscreen (not (equal fullscreen client-id))) + (ewmh-set-client-fullscreen-state backend fullscreen nil))) + (unless (lease-for-client world client-id) + ;; Also reclaim this one available slot in a degraded partial draft. + ;; SHOW preserves an existing placement's kind/geometry and never + ;; reclaims unrelated missing slots as a side effect. + (show-client-on-presentation world client-id (presentation-id presentation))) + (backend-focus-client backend client-id :head-id head-id))) + +(defun backend-focus-head-background (backend head-id) + "Select HEAD-ID while intentionally focusing the root background. + +The Presentation keeps its saved client focus target, ready for a later +keyboard cycle or client click. The root-focus override is frontend state, not +a model change, so clicking blank space never dirties a View." + (%head-for-id backend head-id) + (let ((presentation (current-presentation (x11-backend-world backend) head-id))) + (setf (x11-backend-focused-head-id backend) head-id + (x11-backend-activity-id backend) + (and presentation (presentation-activity-id presentation)) + (x11-backend-focus-root-override-p backend) t) + (apply-active-presentation backend) + (backend-status backend))) + +(defun %focus-relative-client (backend head-id direction) + (let* ((presentation (%current-presentation-or-error backend head-id)) + (world (x11-backend-world backend)) + (client-ids (presentation-leased-client-ids world presentation))) + (when client-ids + (let* ((ordered-client-ids (if (eq direction :previous) + (reverse client-ids) + client-ids)) + (current-client-id (presentation-focus-client-id presentation)) + (suffix (member current-client-id ordered-client-ids :test #'equal)) + (next-client-id (or (second suffix) (first ordered-client-ids)))) + (backend-focus-client backend next-client-id :head-id head-id))))) + +(defun backend-focus-next-client (backend + &key (head-id (x11-backend-focused-head-id backend))) + "Focus the next leased client in the Head's layout/placement order." + (%focus-relative-client backend head-id :next)) + +(defun backend-focus-previous-client (backend + &key (head-id (x11-backend-focused-head-id backend))) + "Focus the previous leased client in the Head's layout/placement order." + (%focus-relative-client backend head-id :previous)) + +(defun %placement-for-client (presentation client-id) + (find client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal)) + +(defun backend-transfer-focused-client-to-head + (backend target-head-id + &key (head-id (x11-backend-focused-head-id backend))) + "Move HEAD-ID's focused client to TARGET-HEAD-ID and follow it with focus. + +Private clients require the same Activity; shared clients can cross Activities +without changing their home membership. If the +target draft already has a placement for the client, that placement controls +its destination geometry/layout. Otherwise Lime adds an unsaved placement +matching the source client's tile/float kind before transferring its lease. +The source remembers its next remaining visible client for a later return. +Keyboard focus and subsequent commands follow the moved client to its Head. + +This is a general command-layer operation, usable from a key, menu, or IPC; +the input layer merely chooses the target Head." + (%head-for-id backend head-id) + (%head-for-id backend target-head-id) + (when (equal head-id target-head-id) + (error 'invalid-transition + :description "A focused client cannot be transferred to its own Head.")) + (let* ((world (x11-backend-world backend)) + (source (%current-presentation-or-error backend head-id)) + (target (%current-presentation-or-error backend target-head-id)) + (client-id (or (presentation-focus-client-id source) + (error 'invalid-transition + :description "The source Head has no focused client.")))) + ;; Verify that this is a currently visible source client before altering + ;; the target draft. The core transfer would enforce the same invariant, + ;; but this produces a direct command-layer diagnostic and avoids a + ;; half-prepared destination on an invalid request. + (unless (member client-id (presentation-leased-client-ids world source) + :test #'equal) + (error 'invalid-transition + :description "The source Head's focused client is not visible.")) + (unless (client-available-in-activity-p world client-id (presentation-activity-id target)) + (error 'invalid-activity-membership + :client-id client-id + :activity-id (presentation-activity-id target))) + (unless (%placement-for-client target client-id) + (let ((source-placement (%placement-for-client source client-id))) + (show-client-on-presentation + world client-id (presentation-id target) + :kind (placement-kind source-placement) + :data (copy-tree (placement-data source-placement)) + :tiled-insertion-position + (configured-new-tiled-client-position backend (presentation-layout-mode target))))) + (transfer-client-lease world client-id (presentation-id target)) + ;; Select it within the destination arrangement so monocle shows it too. + (focus-client-on-presentation world client-id (presentation-id target)) + ;; The core correctly clears a transferred focus target on the source. + ;; Remember a survivor there for when the user returns to that Head. + (let ((next-client-id (first (presentation-leased-client-ids world source)))) + (when next-client-id + (focus-client-on-presentation world next-client-id + (presentation-id source)))) + ;; Select only after a successful move, before rendering, so there is no + ;; intermediate X focus on the source survivor. This also updates routing + ;; for subsequent commands/new windows and clears root-background focus. + (backend-select-head backend target-head-id))) + +(defun backend-transfer-focused-client-relatively + (backend direction &key (head-id (x11-backend-focused-head-id backend))) + "Transfer and follow the focused client to the next or previous Head." + (backend-transfer-focused-client-to-head + backend (%relative-head-id backend head-id direction) :head-id head-id)) + +(defun backend-rehome-client-to-head + (backend client-id target-head-id + &key (head-id (x11-backend-focused-head-id backend)) expected-revision) + "Explicitly change a visible client's Activity, move it, and follow its Head. + +This command never prompts. Interactive callers obtain confirmation first; +EXPECTED-REVISION rejects a stale decision before any membership mutation." + (%head-for-id backend head-id) + (%head-for-id backend target-head-id) + (when (equal head-id target-head-id) + (error 'invalid-transition :description "Choose another Head for this move.")) + (let ((world (x11-backend-world backend))) + (when (and expected-revision (/= expected-revision (world-revision world))) + (error 'stale-transition-plan)) + (%require-visible-client backend client-id head-id) + (let ((target (%current-presentation-or-error backend target-head-id))) + (move-client-to-presentation + world client-id (presentation-id target) + :tiled-insertion-position (configured-new-tiled-client-position backend (presentation-layout-mode target)) + :focus-direction (%membership-focus-policy backend)) + (backend-select-head backend target-head-id)))) + +(defun backend-set-client-fullscreen (backend client-id fullscreen-p) + "Set CLIENT-ID's EWMH fullscreen state and reconcile its leased Head. + +Fullscreen remains frontend state rather than a View edit: its screen-sized +geometry follows the active Lease and the saved arrangement reappears when it +is removed. Enabling a visible client also focuses it, as games expect." + (ewmh-set-client-fullscreen-state backend client-id fullscreen-p) + (let ((head-id (and fullscreen-p + (ewmh-active-head-id-for-client backend client-id)))) + (if head-id + (backend-focus-client backend client-id :head-id head-id) + (apply-active-presentation backend))) + client-id) + +(defun backend-toggle-focused-client-fullscreen + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Toggle EWMH fullscreen for HEAD-ID's focused visible client." + (let* ((presentation (%current-presentation-or-error backend head-id)) + (client-id (or (presentation-focus-client-id presentation) + (error 'invalid-transition + :description "The selected Head has no focused client.")))) + (backend-set-client-fullscreen backend client-id + (not (ewmh-client-fullscreen-p backend client-id))))) + +(defun backend-close-client (backend client-id) + "Ask a managed client to close through ICCCM, then fall back to XKillClient. + +This command does not optimistically retire the model client: DestroyNotify is +the authoritative lifecycle event, so a client that declines or delays close +remains a normal managed window." + (let ((window (gethash client-id (x11-backend-client-windows backend)))) + (unless window + (error 'invalid-transition + :description (format nil "Client ~S has no managed X11 window." + client-id))) + (let ((result (icccm-request-close backend client-id window))) + (xlib:display-force-output (x11-backend-display backend)) + result))) + +(defun backend-close-focused-client + (backend &key (head-id (x11-backend-focused-head-id backend))) + "Ask the focused visible client on HEAD-ID to close through ICCCM." + (let ((presentation (%current-presentation-or-error backend head-id))) + (or (presentation-focus-client-id presentation) + (error 'invalid-transition + :description "The selected Head has no focused client.")) + (backend-close-client backend (presentation-focus-client-id presentation)))) diff --git a/src/x11/config-package.lisp b/src/x11/config-package.lisp new file mode 100644 index 0000000..6f5b570 --- /dev/null +++ b/src/x11/config-package.lisp @@ -0,0 +1,13 @@ +(defpackage #:lime.config + (:use #:cl) + (:documentation + "User-facing Common Lisp configuration for the Lime X11 adapter.") + (:export + #:defconfiguration + #:start-lime + #:load-configuration + #:apply-configuration + #:reload-configuration + #:run-command + #:list-commands + #:find-command)) diff --git a/src/x11/config.lisp b/src/x11/config.lisp new file mode 100644 index 0000000..8881821 --- /dev/null +++ b/src/x11/config.lisp @@ -0,0 +1,891 @@ +(in-package #:lime.x11) + +;;;; User configuration: a small declarative layer over public commands +;;; +;;; Configuration stays outside LIME.CORE. It is adapter policy which says +;;; which input invokes a command, how a freshly mapped X11 client is styled, +;;; and which optional bar providers should run. Activities, Views, leases, +;;; and saved layouts are deliberately never serialized into or reconstructed +;;; from a configuration file. + +(defstruct lime-command + "One user-named imperative command shared by bindings and the palette. + +ACTION is a function of one X11-BACKEND. KEY is optional and only controls +the command's entry under the palette's `User` which-key branch; it does not +create a passive X11 grab by itself." + id + label + description + category + key + action) + +(defstruct configuration-binding + "A declarative passive-key binding to a LIME-COMMAND id." + key + modifiers + command-id + description) + +(defstruct window-rule + "An ordered, initial-placement rule for ordinary newly managed clients. + +RESOURCE-NAME, RESOURCE-CLASS, and TITLE are NIL (wildcard), a string +(case-insensitive exact match), or a predicate of one actual string-or-NIL. +PREDICATE, when supplied, receives BACKEND, CLIENT-ID, and ICCCM-CLIENT-INFO. +The first matching rule wins. The intentionally small initial action set is +FLOAT-P and CENTER-P: it never mounts a View, changes an Activity, or takes a +lease as an incidental result of a WM_CLASS match." + id + resource-name + resource-class + title + predicate + (float-p nil) + (center-p nil)) + +(defstruct layout-client-flow-policy + "Per-layout placement and removal policy for ordinary tiled clients. + +LAYOUT-MODE is one of Lime's built-in layout modes. A configuration may +override only the modes it cares about; its ordinary global client-flow +settings remain the fallback for the others." + layout-mode + (new-tiled-client-position :back) + (close-focus-direction :previous)) + +(defstruct lime-configuration + "A fully evaluated user configuration ready to install on a backend." + (default-keybindings-p nil) + (default-modifiers '(:mod-4)) + (default-layout :master-stack) + ;; Client-flow policy is adapter configuration, not a property of an + ;; Activity or saved View. The defaults deliberately match Lime's starter + ;; workflow: new clients are focused, append at the visual bottom of a + ;; master/stack layout, and focus moves back toward master after removal. + (new-client-focus-p t) + (new-tiled-client-position :back) + (close-focus-direction :previous) + ;; Monocle's meaningful order is its focus cycle rather than its geometry: + ;; a new client becomes the visible one and closing it advances to the next + ;; older client. Further entries selectively override this built-in policy. + (layout-client-flow-policies + (list (make-layout-client-flow-policy + :layout-mode :monocle + :new-tiled-client-position :front + :close-focus-direction :next))) + (commands '()) + (bindings '()) + (rules '()) + (appearance (make-window-appearance)) + (bar-style (make-head-bar-style)) + (font (make-ui-font-style)) + (cursor (make-ui-cursor-style)) + bar-height + (bar-height-supplied-p nil) + status-providers + (status-providers-supplied-p nil) + (startup-hooks '())) + +(defvar *lime-configuration-definitions* (make-hash-table :test #'eq) + "Configuration name symbol -> latest object defined by DEFCONFIGURATION.") + +(defvar *lime-configuration-load-names* nil + "Dynamically collects definitions evaluated by LOAD-LIME-CONFIGURATION.") + +(defun register-lime-configuration (name configuration) + "Register NAME as CONFIGURATION and return CONFIGURATION. + +DEFCONFIGURATION calls this while a user file is loaded. It is public mostly +for people constructing a configuration entirely from ordinary Lisp instead +of the small macro surface." + (unless (symbolp name) + (error 'invalid-transition + :description "A Lime configuration name must be a symbol.")) + (unless (typep configuration 'lime-configuration) + (error 'invalid-transition + :description "A registered Lime configuration must be a LIME-CONFIGURATION.")) + (setf (gethash name *lime-configuration-definitions*) configuration) + (when (boundp '*lime-configuration-load-names*) + (pushnew name *lime-configuration-load-names* :test #'eq)) + configuration) + +(defun find-lime-configuration (name) + "Return the configuration registered as NAME, or signal a useful error." + (or (gethash name *lime-configuration-definitions*) + (error 'invalid-transition + :description (format nil "No Lime configuration named ~S is loaded." name)))) + +(defun %configuration-name-from-load (names requested-name) + (cond + (requested-name + (unless (member requested-name names :test #'eq) + (error 'invalid-transition + :description + (format nil "Configuration file did not define the requested ~S configuration." + requested-name))) + requested-name) + ((null names) + (error 'invalid-transition + :description "The configuration file did not evaluate DEFCONFIGURATION.")) + ((null (rest names)) + (first names)) + (t + (error 'invalid-transition + :description + (format nil "The configuration file defined ~{~S~^, ~}; choose one with :NAME." + names))))) + +(defun load-lime-configuration (path &key name) + "Load PATH and return its one newly defined LIME-CONFIGURATION. + +When a file deliberately defines several configurations, NAME selects one of +the symbols it defined during this load. The second return value is that +symbol, retained by a backend so `reload-configuration` can faithfully reload +the same choice later. Loading evaluates normal Common Lisp; keep the file's +top-level effects limited to configuration definitions and helper functions." + (let ((*lime-configuration-load-names* '())) + (load path) + (let* ((names (nreverse *lime-configuration-load-names*)) + (selected-name (%configuration-name-from-load names name))) + (values (find-lime-configuration selected-name) selected-name)))) + +(defun %configuration-command-id-valid-p (id) + (or (symbolp id) (stringp id) (integerp id))) + +(defun %configuration-modifiers-valid-p (modifiers) + (or (integerp modifiers) (listp modifiers))) + +(defun %configuration-duplicate-p (items key-function &key (test #'equal)) + ;; The configuration lists are intentionally tiny, and MEMBER lets the + ;; which-key alphabet use CHAR-EQUAL (which MAKE-HASH-TABLE cannot accept + ;; as an equivalence relation) without a separate normalization path. + (let ((seen '())) + (loop for item in items + for key = (funcall key-function item) + thereis (if (member key seen :test test) + t + (progn (push key seen) nil))))) + +(defun %validate-window-rule (rule) + (unless (typep rule 'window-rule) + (error 'invalid-transition + :description "Configuration rules must be WINDOW-RULE objects.")) + (dolist (value (list (window-rule-resource-name rule) + (window-rule-resource-class rule) + (window-rule-title rule))) + (unless (or (null value) (stringp value) (functionp value)) + (error 'invalid-transition + :description "A window-rule matcher must be NIL, a string, or a function."))) + (when (and (window-rule-predicate rule) + (not (functionp (window-rule-predicate rule)))) + (error 'invalid-transition + :description "A window-rule :PREDICATE must be a function.")) + (when (and (window-rule-center-p rule) (not (window-rule-float-p rule))) + (error 'invalid-transition + :description "A centered window rule must also specify :FLOAT T.")) + rule) + +(defun %validate-lime-configuration (configuration) + "Check all reloadable policy before changing any installed backend state." + (unless (typep configuration 'lime-configuration) + (error 'invalid-transition + :description "Expected a LIME-CONFIGURATION.")) + (unless (%configuration-modifiers-valid-p + (lime-configuration-default-modifiers configuration)) + (error 'invalid-transition + :description "Configuration default modifiers must be a list or integer mask.")) + (unless (member (lime-configuration-default-layout configuration) + '(:manual :master-stack :monocle)) + (error 'invalid-transition + :description "Configuration :DEFAULT-LAYOUT must be :MANUAL, :MASTER-STACK, or :MONOCLE.")) + (unless (member (lime-configuration-new-client-focus-p configuration) '(t nil)) + (error 'invalid-transition + :description "Configuration :NEW-CLIENT-FOCUS must be T or NIL.")) + (unless (member (lime-configuration-new-tiled-client-position configuration) + '(:front :back)) + (error 'invalid-transition + :description "Configuration :NEW-TILED-CLIENT-POSITION must be :FRONT or :BACK.")) + (unless (member (lime-configuration-close-focus-direction configuration) + '(:previous :next)) + (error 'invalid-transition + :description "Configuration :CLOSE-FOCUS-DIRECTION must be :PREVIOUS or :NEXT.")) + (let ((policies (lime-configuration-layout-client-flow-policies configuration))) + (unless (and (listp policies) + (every (lambda (policy) + (and (typep policy 'layout-client-flow-policy) + (member (layout-client-flow-policy-layout-mode policy) + '(:manual :master-stack :monocle)) + (member (layout-client-flow-policy-new-tiled-client-position policy) + '(:front :back)) + (member (layout-client-flow-policy-close-focus-direction policy) + '(:previous :next)))) + policies)) + (error 'invalid-transition + :description "Each layout client-flow policy needs a known layout mode, :FRONT/:BACK insertion, and :PREVIOUS/:NEXT close direction.")) + (when (%configuration-duplicate-p policies + #'layout-client-flow-policy-layout-mode) + (error 'invalid-transition + :description "A configuration may define at most one client-flow policy per layout mode."))) + (let ((commands (lime-configuration-commands configuration)) + (bindings (lime-configuration-bindings configuration))) + (unless (every (lambda (command) + (and (typep command 'lime-command) + (%configuration-command-id-valid-p (lime-command-id command)) + (stringp (lime-command-label command)) + (functionp (lime-command-action command)) + (or (null (lime-command-key command)) + (characterp (lime-command-key command))))) + commands) + (error 'invalid-transition + :description "Every configuration command needs an id, string label, function action, and optional character key.")) + (when (%configuration-duplicate-p commands #'lime-command-id) + (error 'invalid-transition + :description "Configuration command ids must be unique.")) + (when (%configuration-duplicate-p (remove nil (mapcar #'lime-command-key commands)) #'identity + :test #'char-equal) + (error 'invalid-transition + :description "Configuration which-key command letters must be unique.")) + (unless (every (lambda (binding) + (and (typep binding 'configuration-binding) + (or (characterp (configuration-binding-key binding)) + (and (integerp (configuration-binding-key binding)) + (not (minusp (configuration-binding-key binding))))) + (%configuration-modifiers-valid-p + (configuration-binding-modifiers binding)) + (find (configuration-binding-command-id binding) commands + :key #'lime-command-id :test #'equal))) + bindings) + (error 'invalid-transition + :description "Each configuration binding needs a key, valid modifiers, and a configured command id.")) + (when (%configuration-duplicate-p + bindings + (lambda (binding) + (list (configuration-binding-key binding) + (configuration-binding-modifiers binding)))) + (error 'invalid-transition + :description "Configuration key/modifier pairs must be unique."))) + (dolist (rule (lime-configuration-rules configuration)) + (%validate-window-rule rule)) + (%validate-window-appearance (lime-configuration-appearance configuration)) + (%validate-head-bar-style (lime-configuration-bar-style configuration)) + (%validate-ui-font-style (lime-configuration-font configuration)) + (%validate-ui-cursor-style (lime-configuration-cursor configuration)) + (when (lime-configuration-bar-height-supplied-p configuration) + (unless (and (integerp (lime-configuration-bar-height configuration)) + (not (minusp (lime-configuration-bar-height configuration)))) + (error 'invalid-transition + :description "A configured bar height must be a non-negative integer."))) + (when (lime-configuration-status-providers-supplied-p configuration) + (%validate-status-providers (lime-configuration-status-providers configuration))) + (unless (every #'functionp (lime-configuration-startup-hooks configuration)) + (error 'invalid-transition + :description "Configuration startup hooks must be functions.")) + configuration) + +(defun configured-new-client-focus-p (backend) + "Return BACKEND's ordinary newly-managed-client focus policy." + (let ((configuration (x11-backend-configuration backend))) + (if configuration + (lime-configuration-new-client-focus-p configuration) + t))) + +(defun configured-default-layout (backend) + "Initial layout for a new Head-local draft; never reapplied on resume/reload." + (let ((configuration (x11-backend-configuration backend))) + (if configuration + (lime-configuration-default-layout configuration) + (x11-backend-default-layout backend)))) + +(defun %configured-layout-client-flow-policy (backend layout-mode) + "Return the optional explicit policy for LAYOUT-MODE on BACKEND." + (let ((configuration (x11-backend-configuration backend))) + (and configuration + (find layout-mode + (lime-configuration-layout-client-flow-policies configuration) + :key #'layout-client-flow-policy-layout-mode)))) + +(defun configured-new-tiled-client-position (backend layout-mode) + "Return where new tiled clients enter LAYOUT-MODE's placement ordering." + (let ((policy (%configured-layout-client-flow-policy backend layout-mode)) + (configuration (x11-backend-configuration backend))) + (cond + (policy (layout-client-flow-policy-new-tiled-client-position policy)) + ((eq layout-mode :monocle) :front) + (configuration (lime-configuration-new-tiled-client-position configuration)) + (t :back)))) + +(defun configured-close-focus-direction (backend layout-mode) + "Return the removal focus direction preferred by LAYOUT-MODE." + (let ((policy (%configured-layout-client-flow-policy backend layout-mode)) + (configuration (x11-backend-configuration backend))) + (cond + (policy (layout-client-flow-policy-close-focus-direction policy)) + ((eq layout-mode :monocle) :next) + (configuration (lime-configuration-close-focus-direction configuration)) + (t :previous)))) + +(defun list-configured-commands (backend) + "Return BACKEND's user-defined commands in configuration order." + (copy-list + (and (x11-backend-configuration backend) + (lime-configuration-commands (x11-backend-configuration backend))))) + +(defun find-configured-command (backend command-id) + "Find a configured command by id, without inventing a fallback behavior." + (or (find command-id (list-configured-commands backend) + :key #'lime-command-id :test #'equal) + (error 'invalid-transition + :description (format nil "No configured command named ~S exists." command-id)))) + +(defun run-configured-command (backend command-id) + "Run COMMAND-ID against BACKEND and return its ordinary Lisp result." + (funcall (lime-command-action (find-configured-command backend command-id)) + backend)) + +(defun %restore-keybindings (backend bindings) + "Restore a captured binding list after a failed configuration install." + (dolist (binding bindings) + (bind-key backend (keybinding-key binding) (keybinding-modifiers binding) + (keybinding-handler binding) + :description (keybinding-description binding)))) + +(defun %install-configuration-bindings (backend configuration) + (clear-keybindings backend) + (when (lime-configuration-default-keybindings-p configuration) + (install-default-keybindings + backend :modifiers (lime-configuration-default-modifiers configuration))) + (dolist (binding (lime-configuration-bindings configuration)) + (let ((command-id (configuration-binding-command-id binding))) + (bind-key + backend + (configuration-binding-key binding) + (configuration-binding-modifiers binding) + (lambda (bound-backend) + (run-configured-command bound-backend command-id)) + :description + (or (configuration-binding-description binding) + (lime-command-description + (find-configured-command backend command-id))))))) + +(defun apply-lime-configuration (backend configuration + &key source name (run-startup-hooks-p nil)) + "Install CONFIGURATION while preserving the running Lime world. + +All type, rule, command, and binding-reference checks happen before touching +the X server. A later passive-grab/render error restores the previous binding +set, appearance, and bar settings before the error is re-signalled. Reloading normally +leaves startup hooks alone; START-LIME opts into them once after initial +installation so a reload can never unexpectedly launch another program." + (%validate-lime-configuration configuration) + (let ((old-configuration (x11-backend-configuration backend)) + (old-source (x11-backend-configuration-source backend)) + (old-name (x11-backend-configuration-name backend)) + (old-appearance (x11-backend-window-appearance backend)) + (old-bindings (list-keybindings backend)) + (old-bar-height (x11-backend-head-bar-height backend)) + (old-cursors (x11-backend-cursor-set backend)) + (session-settings-touched-p nil) + (new-cursors nil) + (old-status-providers + (copy-list (x11-backend-head-bar-status-providers backend)))) + (handler-case + (progn + ;; Keep the old XIDs alive until every other config operation commits. + (setf new-cursors (%prepare-cursor-set backend (lime-configuration-cursor configuration))) + (%install-cursor-set backend new-cursors) + ;; Give bound handlers the complete new command registry before + ;; they can ever be dispatched by X after the next output flush. + (setf (x11-backend-configuration backend) configuration + (x11-backend-configuration-source backend) source + (x11-backend-configuration-name backend) name + (x11-backend-window-appearance backend) + (lime-configuration-appearance configuration)) + ;; Resolve both colors before touching window geometry. Allocation + ;; errors still take the same configuration rollback path. + (%border-pixel backend (window-appearance-focused-border + (lime-configuration-appearance configuration))) + (%border-pixel backend (window-appearance-unfocused-border + (lime-configuration-appearance configuration))) + (%install-configuration-bindings backend configuration) + (when (lime-configuration-bar-height-supplied-p configuration) + (backend-set-head-bar-height backend + (lime-configuration-bar-height configuration))) + (when (lime-configuration-status-providers-supplied-p configuration) + (backend-set-head-bar-status-providers + backend (lime-configuration-status-providers configuration))) + (apply-active-presentation backend) + (%render-command-palette backend) + ;; Unlike ordinary frames, installation needs a server roundtrip: + ;; catch asynchronous grab/configure errors inside this rollback. + (xlib:display-finish-output (x11-backend-display backend)) + (setf session-settings-touched-p t) + (%apply-cursor-session-settings backend (lime-configuration-cursor configuration)) + (when run-startup-hooks-p + (dolist (hook (lime-configuration-startup-hooks configuration)) + (funcall hook backend))) + (%prune-border-colors backend) + (%free-cursor-set old-cursors) + configuration) + (error (condition) + ;; This path is specifically about reconfiguration plumbing, never + ;; core world state. Activities, Presentations, Views, and leases + ;; were untouched and thus need no rollback. + (ignore-errors (clear-keybindings backend)) + (ignore-errors (%restore-keybindings backend old-bindings)) + (setf (x11-backend-configuration backend) old-configuration + (x11-backend-configuration-source backend) old-source + (x11-backend-configuration-name backend) old-name + (x11-backend-window-appearance backend) old-appearance) + (ignore-errors (%install-cursor-set backend old-cursors)) + (when session-settings-touched-p + (ignore-errors + (%apply-cursor-session-settings + backend (if old-configuration (lime-configuration-cursor old-configuration) + (make-ui-cursor-style))))) + (%free-cursor-set new-cursors) + (ignore-errors (backend-set-head-bar-height backend old-bar-height)) + (ignore-errors (backend-set-head-bar-status-providers backend old-status-providers)) + (ignore-errors (apply-active-presentation backend)) + (ignore-errors (%render-command-palette backend)) + (ignore-errors (xlib:display-finish-output (x11-backend-display backend))) + (ignore-errors (%prune-border-colors backend)) + (error condition))))) + +(defun configure-backend-from-file (backend path &key name (run-startup-hooks-p nil)) + "Load PATH then install its selected configuration on BACKEND." + (multiple-value-bind (configuration selected-name) + (load-lime-configuration path :name name) + (apply-lime-configuration backend configuration + :source (namestring (truename path)) + :name selected-name + :run-startup-hooks-p run-startup-hooks-p))) + +(defun reload-backend-configuration (backend) + "Reload BACKEND's original configuration file without rerunning startup hooks." + (let ((source (x11-backend-configuration-source backend))) + (unless source + (error 'invalid-transition + :description "This backend was not started from a configuration file.")) + (configure-backend-from-file backend source + :name (x11-backend-configuration-name backend)))) + +(defun %configuration-argument-plist-without (arguments removed-keys) + (loop for (key value) on arguments by #'cddr + unless (member key removed-keys) + append (list key value))) + +(defun start-lime (&rest start-arguments + &key config-file configuration-name &allow-other-keys) + "Start Lime and, when CONFIG-FILE is given, install its user configuration. + +CONFIG-FILE configurations replace the starter keymap as one unit; request it +again from `(:OPTIONS :DEFAULT-KEYBINDINGS T)` when desired. With no config +file this simply forwards to START-BACKEND and retains its normal defaults. +The file's DEFAULT-LAYOUT takes precedence over the startup keyword." + (if (null config-file) + (apply #'start-backend + (%configuration-argument-plist-without + start-arguments '(:config-file :configuration-name))) + (multiple-value-bind (configuration selected-name) + (load-lime-configuration config-file :name configuration-name) + ;; Validate before claiming X or creating bootstrap drafts. The rest of + ;; the configuration is installed once the backend resources exist. + (%validate-lime-configuration configuration) + (let ((backend + (apply #'start-backend + (append + (%configuration-argument-plist-without + start-arguments + '(:config-file :configuration-name + :install-default-keybindings-p :default-layout)) + (list :install-default-keybindings-p nil + :default-layout + (lime-configuration-default-layout configuration)))))) + (handler-case + (progn + (apply-lime-configuration backend configuration + :source (namestring (truename config-file)) + :name selected-name + :run-startup-hooks-p t) + backend) + (error (condition) + (stop-backend backend :save-session-p nil) + (error condition))))))) + +(defun %rule-text-matches-p (expected actual) + (cond + ((null expected) t) + ((stringp expected) (and actual (string-equal expected actual))) + ((functionp expected) (not (null (funcall expected actual)))) + (t nil))) + +(defun %matching-window-rule (backend client-id info) + (let ((configuration (x11-backend-configuration backend))) + (when configuration + (find-if + (lambda (rule) + (and (%rule-text-matches-p (window-rule-resource-name rule) + (icccm-client-info-resource-name info)) + (%rule-text-matches-p (window-rule-resource-class rule) + (icccm-client-info-resource-class info)) + (%rule-text-matches-p (window-rule-title rule) + (icccm-client-info-title info)) + (or (null (window-rule-predicate rule)) + (funcall (window-rule-predicate rule) backend client-id info)))) + (lime-configuration-rules configuration))))) + +(defun apply-configured-window-rules (backend client-id window decision) + "Return DECISION styled by the first matching ordinary-client window rule. + +Rules are evaluated after ICCCM facts have been cached but before the new +client joins any Presentation. They do not run for transients (whose parent +placement is mandatory) or dialog-like EWMH clients, and they do not route +between Activities or Heads. A matching non-floating rule overrides the +ordinary fixed-size floating default." + (let* ((info (backend-client-icccm-info backend client-id)) + (rule (and info (%matching-window-rule backend client-id info)))) + (when rule + (if (window-rule-float-p rule) + (let ((head (%head-for-id backend + (x11-placement-decision-head-id decision)))) + (setf (x11-placement-decision-kind decision) :float + (x11-placement-decision-data decision) + (if (window-rule-center-p rule) + (%centered-floating-data-for-window backend client-id window head) + (%floating-data-for-window backend client-id window head nil)))) + (setf (x11-placement-decision-kind decision) :tile + (x11-placement-decision-data decision) nil))) + decision)) + +(defun configuration-command-candidates (backend) + "Make direct-search candidates for every first-class configured command." + (mapcar + (lambda (command) + (let ((command-id (lime-command-id command))) + (make-ui-candidate + :id (list :configured-command command-id) + :label (format nil "Command: ~A" (lime-command-label command)) + :detail (or (lime-command-description command) + (format nil "~A command" (or (lime-command-category command) + "User"))) + :key-hint "Enter" + :action + (lambda () + (let ((result (run-configured-command backend command-id))) + (if (typep result 'ui-result) + result + (ui-close-result + (or (lime-command-description command) + (format nil "Ran ~A." (lime-command-label command)))))))))) + (list-configured-commands backend))) + +(defun configuration-command-key-nodes (backend) + "Return optional `User` which-key children declared by configuration." + (loop for command in (list-configured-commands backend) + when (lime-command-key command) + collect + (let ((command-id (lime-command-id command))) + (make-ui-key-node + :id (list :configured-command command-id) + :key (lime-command-key command) + :label (lime-command-label command) + :detail (or (lime-command-description command) + (format nil "~A command" (or (lime-command-category command) + "User"))) + :action + (lambda () + (let ((result (run-configured-command backend command-id))) + (if (typep result 'ui-result) + result + (ui-close-result + (or (lime-command-description command) + (format nil "Ran ~A." (lime-command-label command))))))))))) + +(in-package #:lime.config) + +;;;; Small, readable source-file DSL + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun %configuration-option (options key &optional default) + (if (member key options) + (getf options key) + default)) + + (defun %require-configuration-options (options allowed context) + (unless (evenp (length options)) + (error "~A needs keyword/value pairs, got ~S." context options)) + (loop for key in options by #'cddr + do (unless (member key allowed) + (error "~A does not understand ~S." context key))))) + +(defun %configuration-command-label (id) + (etypecase id + (symbol (string-capitalize (symbol-name id))) + (string id) + (integer (princ-to-string id)))) + +(defmacro defconfiguration (name &body clauses) + "Define and register one reloadable Lime user configuration. + +The compact clauses are deliberately data-first Common Lisp: + + (:OPTIONS :DEFAULT-KEYBINDINGS T :DEFAULT-MODIFIERS '(:MOD-4) + :DEFAULT-LAYOUT :MASTER-STACK + :NEW-CLIENT-FOCUS T :NEW-TILED-CLIENT-POSITION :BACK + :CLOSE-FOCUS-DIRECTION :PREVIOUS) + (:LAYOUT-FLOW :MONOCLE :NEW-TILED-CLIENT-POSITION :FRONT + :CLOSE-FOCUS-DIRECTION :NEXT) + (:COMMAND terminal :LABEL 'Terminal' :ACTION (lambda (backend) ...)) + (:BIND #\Return terminal :MODIFIERS '(:MOD-4)) + (:RULE :CLASS 'mpv' :FLOAT T :CENTER T) + (:FONT :FAMILY 'monospace' :SIZE 14 :WEIGHT :NORMAL) + (:BAR :HEIGHT 22 :STATUS-PROVIDERS (list #'my-status)) + (:APPEARANCE :BORDER-WIDTH 3 :INNER-GAP 5 :OUTER-GAP 5) + (:STARTUP (lambda (backend) ...)) + +Commands become searchable palette entries automatically. Give a command +`:KEY #\t` to also place it under the palette's `User` which-key branch; +bind it separately when it needs a physical X key." + (unless (symbolp name) + (error "DEFCONFIGURATION needs a symbol name, got ~S." name)) + (let ((options '()) + (layout-flow-options '()) + (commands '()) + (bindings '()) + (rules '()) + (bar-options nil) + (font-options nil) + (font-supplied-p nil) + (cursor-options nil) + (cursor-supplied-p nil) + (appearance-options nil) + (appearance-supplied-p nil) + (startup-hooks '()) + (rule-number 0)) + (dolist (clause clauses) + (unless (consp clause) + (error "A configuration clause must be a list, got ~S." clause)) + (case (first clause) + (:options + (when options + (error "DEFCONFIGURATION accepts only one :OPTIONS clause.")) + (setf options (rest clause)) + (%require-configuration-options + options '(:default-keybindings :default-modifiers :default-layout + :new-client-focus :new-tiled-client-position + :close-focus-direction) + ":OPTIONS")) + (:layout-flow + (unless (second clause) + (error ":LAYOUT-FLOW needs a layout mode.")) + (let ((flow-options (cddr clause))) + (%require-configuration-options + flow-options '(:new-tiled-client-position :close-focus-direction) + ":LAYOUT-FLOW") + (push (list (second clause) flow-options) layout-flow-options))) + (:command + (unless (second clause) + (error ":COMMAND needs an id.")) + (let ((command-options (cddr clause))) + (%require-configuration-options + command-options '(:label :description :category :key :action) ":COMMAND") + (unless (member :action command-options) + (error ":COMMAND ~S needs an :ACTION." (second clause))) + (push (list (second clause) command-options) commands))) + (:bind + (unless (and (second clause) (third clause)) + (error ":BIND needs a key and a command id.")) + (let ((binding-options (cdddr clause))) + (%require-configuration-options + binding-options '(:modifiers :description) ":BIND") + (push (list (second clause) (third clause) binding-options) bindings))) + (:navigation-keys + (%require-configuration-options (rest clause) '(:modifiers) ":NAVIGATION-KEYS") + ;; Expand into ordinary named commands/bindings, so validation, + ;; configuration reload, and custom overrides share the usual path. + (let ((modifiers (%configuration-option + (rest clause) :modifiers + (%configuration-option (cdr (assoc :options clauses)) + :default-modifiers ''(:mod-4))))) + (loop for slot from 1 to 10 for key across "1234567890" do + (dolist (kind '(:activity :view)) + (let* ((view-p (eq kind :view)) + (id (intern (format nil "NAVIGATE-~A-~D" kind slot) :keyword)) + (label (format nil "Select ~A slot ~D" (if view-p "local View" "Activity") slot))) + (push (list id (list :label label :category "Navigation" + :action `(lambda (backend) + (,(if view-p 'lime.x11:backend-select-view-slot + 'lime.x11:backend-select-activity-slot) backend ,slot)))) commands) + (push (list key id (list :modifiers (if view-p + `(lime.x11::%default-modifiers ,modifiers '(:shift)) + modifiers))) bindings)))))) + (:rule + (let ((rule-options (rest clause))) + (%require-configuration-options + rule-options '(:id :name :class :title :predicate :float :center) ":RULE") + (incf rule-number) + (push (list rule-number rule-options) rules))) + (:bar + (when bar-options + (error "DEFCONFIGURATION accepts only one :BAR clause.")) + (setf bar-options (rest clause)) + (%require-configuration-options + bar-options '(:height :status-providers :padding-x :background :foreground + :focused-background :focused-foreground + :unfocused-background :unfocused-foreground + :accent-color :menu-label-color :logo-color + :separator-color :title-edge-color :attention-color + :attention-marker :attention-indicator-p) ":BAR")) + (:font + (when font-supplied-p (error "DEFCONFIGURATION accepts only one :FONT clause.")) + (setf font-options (rest clause) font-supplied-p t) + (%require-configuration-options font-options '(:family :size :weight) ":FONT")) + (:cursor + (when cursor-supplied-p (error "DEFCONFIGURATION accepts only one :CURSOR clause.")) + (setf cursor-options (rest clause) cursor-supplied-p t) + (%require-configuration-options cursor-options '(:theme :size) ":CURSOR")) + (:appearance + (when appearance-supplied-p + (error "DEFCONFIGURATION accepts only one :APPEARANCE clause.")) + (setf appearance-options (rest clause) appearance-supplied-p t) + (%require-configuration-options + appearance-options '(:border-width :focused-border :unfocused-border + :inner-gap :outer-gap) ":APPEARANCE")) + (:startup + (unless (= (length (rest clause)) 1) + (error ":STARTUP needs exactly one function expression.")) + (push (second clause) startup-hooks)) + (otherwise + (error "DEFCONFIGURATION does not understand ~S." (first clause))))) + (let ((configuration (gensym "CONFIGURATION"))) + `(progn + (defparameter ,name + (let ((,configuration + (lime.x11:make-lime-configuration + :appearance (lime.x11:make-window-appearance ,@appearance-options) + :font (lime.x11:make-ui-font-style ,@font-options) + :cursor (lime.x11:make-ui-cursor-style ,@cursor-options) + :default-keybindings-p + ,(%configuration-option options :default-keybindings nil) + :default-modifiers + ,(%configuration-option options :default-modifiers ''(:mod-4)) + :default-layout + ,(%configuration-option options :default-layout :master-stack) + :new-client-focus-p + ,(%configuration-option options :new-client-focus t) + :new-tiled-client-position + ,(%configuration-option options :new-tiled-client-position :back) + :close-focus-direction + ,(%configuration-option options :close-focus-direction :previous) + :layout-client-flow-policies + (list + ,@(mapcar + (lambda (entry) + (destructuring-bind (layout-mode flow-options) entry + `(lime.x11:make-layout-client-flow-policy + :layout-mode ',layout-mode + :new-tiled-client-position + ,(%configuration-option + flow-options :new-tiled-client-position :back) + :close-focus-direction + ,(%configuration-option + flow-options :close-focus-direction :previous)))) + (nreverse layout-flow-options)))))) + ,@(mapcar + (lambda (entry) + (destructuring-bind (id command-options) entry + `(push + (lime.x11:make-lime-command + :id ',id + :label ,(%configuration-option command-options :label + (%configuration-command-label id)) + :description ,(%configuration-option command-options :description nil) + :category ,(%configuration-option command-options :category "User") + :key ,(%configuration-option command-options :key nil) + :action ,(%configuration-option command-options :action)) + (lime.x11:lime-configuration-commands ,configuration)))) + (nreverse commands)) + (setf (lime.x11:lime-configuration-commands ,configuration) + (nreverse (lime.x11:lime-configuration-commands ,configuration))) + ,@(mapcar + (lambda (entry) + (destructuring-bind (key command-id binding-options) entry + `(push + (lime.x11:make-configuration-binding + :key ,key + :command-id ',command-id + :modifiers + ,(%configuration-option + binding-options :modifiers + `(lime.x11:lime-configuration-default-modifiers ,configuration)) + :description ,(%configuration-option binding-options :description nil)) + (lime.x11:lime-configuration-bindings ,configuration)))) + (nreverse bindings)) + (setf (lime.x11:lime-configuration-bindings ,configuration) + (nreverse (lime.x11:lime-configuration-bindings ,configuration))) + ,@(mapcar + (lambda (entry) + (destructuring-bind (number rule-options) entry + `(push + (lime.x11:make-window-rule + :id ',(%configuration-option rule-options :id + (intern (format nil "RULE-~D" number) + :keyword)) + :resource-name ,(%configuration-option rule-options :name nil) + :resource-class ,(%configuration-option rule-options :class nil) + :title ,(%configuration-option rule-options :title nil) + :predicate ,(%configuration-option rule-options :predicate nil) + :float-p ,(%configuration-option rule-options :float nil) + :center-p ,(%configuration-option rule-options :center nil)) + (lime.x11:lime-configuration-rules ,configuration)))) + (nreverse rules)) + (setf (lime.x11:lime-configuration-rules ,configuration) + (nreverse (lime.x11:lime-configuration-rules ,configuration))) + ,@(when (member :height bar-options) + `((setf (lime.x11:lime-configuration-bar-height ,configuration) + ,(%configuration-option bar-options :height) + (lime.x11:lime-configuration-bar-height-supplied-p ,configuration) t))) + (setf (lime.x11:lime-configuration-bar-style ,configuration) + (lime.x11:make-head-bar-style + ,@(loop for (key value) on bar-options by #'cddr + unless (member key '(:height :status-providers)) + append (list key value)))) + ,@(when (member :status-providers bar-options) + `((setf (lime.x11:lime-configuration-status-providers ,configuration) + ,(%configuration-option bar-options :status-providers) + (lime.x11:lime-configuration-status-providers-supplied-p ,configuration) t))) + (setf (lime.x11:lime-configuration-startup-hooks ,configuration) + (list ,@(nreverse startup-hooks))) + ,configuration)) + (lime.x11:register-lime-configuration ',name ,name) + ',name)))) + +(defun load-configuration (path &key name) + "Load PATH through the DEFCONFIGURATION registry." + (lime.x11:load-lime-configuration path :name name)) + +(defun apply-configuration (backend configuration &key source name) + "Install a prebuilt CONFIGURATION on BACKEND without running startup hooks." + (lime.x11:apply-lime-configuration backend configuration :source source :name name)) + +(defun reload-configuration (backend) + "Reload BACKEND's original configuration file safely." + (lime.x11:reload-backend-configuration backend)) + +(defun start-lime (&rest arguments) + "Start the X11 backend, optionally using :CONFIG-FILE and :CONFIGURATION-NAME." + (apply #'lime.x11:start-lime arguments)) + +(defun run-command (backend command-id) + "Run a named command from BACKEND's installed user configuration." + (lime.x11:run-configured-command backend command-id)) + +(defun list-commands (backend) + "List first-class user commands available on BACKEND." + (lime.x11:list-configured-commands backend)) + +(defun find-command (backend command-id) + "Find one installed user command by id." + (lime.x11:find-configured-command backend command-id)) diff --git a/src/x11/cursor.lisp b/src/x11/cursor.lisp new file mode 100644 index 0000000..4682f43 --- /dev/null +++ b/src/x11/cursor.lisp @@ -0,0 +1,211 @@ +(in-package #:lime.x11) + +;;;; Cursor assets and resource ownership, separate from pointer routing. +;;;; Xcursor reads files into memory; CLX owns all X resources and requests. + +(defstruct ui-cursor-style + "NIL follows Xcursor environment/Xresources/defaults; :CORE disables themes." + theme size) + +(defun %cursor-theme-name-p (value) + (and (stringp value) (plusp (length (string-trim '(#\Space #\Tab #\Newline) value))) + (notany (lambda (char) (member char '(#\Null #\Newline #\Return))) value))) + +(defun %validate-ui-cursor-style (style) + (unless (and (typep style 'ui-cursor-style) + (or (member (ui-cursor-style-theme style) '(nil :core)) + (%cursor-theme-name-p (ui-cursor-style-theme style))) + (or (null (ui-cursor-style-size style)) + (and (integerp (ui-cursor-style-size style)) + (<= 8 (ui-cursor-style-size style) 256)))) + (error 'invalid-transition + :description "Cursor :THEME must be NIL, :CORE, or a nonblank single-line theme name; :SIZE must be NIL or 8..256 pixels.")) + style) + +(defun %cursor-size-value (text) + (when (stringp text) + (let ((number (ignore-errors (parse-integer text)))) + (when (and number (<= 8 number 256)) number)))) + +(defun %resolve-cursor-settings (style environment-theme environment-size resource-theme resource-size dpi) + "Pure precedence: explicit config, environment, Xresources, system default." + (%validate-ui-cursor-style style) + (let ((dpi-number (and (stringp dpi) (ignore-errors (parse-integer dpi :junk-allowed t))))) + (values (or (ui-cursor-style-theme style) + (and (%cursor-theme-name-p environment-theme) environment-theme) + (and (%cursor-theme-name-p resource-theme) resource-theme) + "default") + (or (ui-cursor-style-size style) + (%cursor-size-value environment-size) (%cursor-size-value resource-size) + (and dpi-number (plusp dpi-number) (min 256 (max 8 (round (* dpi-number 16/72))))) + 24)))) + +(declaim (ftype function %cursor-system-resources %cursor-session-report)) +(defun %backend-cursor-settings (backend style) + (let ((resources (%cursor-system-resources backend))) + (%resolve-cursor-settings + style (uiop:getenv "XCURSOR_THEME") (uiop:getenv "XCURSOR_SIZE") + (xlib:get-resource resources :|theme| :|Theme| '(:|Xcursor|) '(:|Xcursor|)) + (xlib:get-resource resources :|size| :|Size| '(:|Xcursor|) '(:|Xcursor|)) + (xlib:get-resource resources :|dpi| :|Dpi| '(:|Xft|) '(:|Xft|))))) + +(cffi:define-foreign-library ui-xcursor (:unix (:or "libXcursor.so.1" "libXcursor.so"))) +(cffi:defcstruct native-cursor-image + (version :uint32) (size :uint32) (width :uint32) (height :uint32) + (xhot :uint32) (yhot :uint32) (delay :uint32) (pixels :pointer)) +(cffi:defcstruct native-cursor-images (count :int) (images :pointer) (name :pointer)) +(cffi:defcfun ("XcursorLibraryLoadImages" %xcursor-load-images) :pointer + (name :string) (theme :string) (size :int)) +(cffi:defcfun ("XcursorImagesDestroy" %xcursor-free-images) :void (images :pointer)) + +(defvar *cursor-library-loaded-p* nil) +(defun %ensure-cursor-library () + (unless *cursor-library-loaded-p* + (cffi:load-foreign-library 'ui-xcursor) + (setf *cursor-library-loaded-p* t))) + +(defstruct cursor-frame pixels xhot yhot delay) + +(defun %copy-native-cursor-frames (images) + "Copy bounded native data before releasing Xcursor's allocation." + (let ((count (cffi:foreign-slot-value images '(:struct native-cursor-images) 'count)) + (array (cffi:foreign-slot-value images '(:struct native-cursor-images) 'images))) + (unless (and (<= 1 count 256) (not (cffi:null-pointer-p array))) + (error "Invalid cursor animation frame count.")) + (loop for i below count for frame = (cffi:mem-aref array :pointer i) + collect + (progn + (when (cffi:null-pointer-p frame) (error "Missing cursor image.")) + (cffi:with-foreign-slots ((width height xhot yhot delay pixels) frame (:struct native-cursor-image)) + (unless (and (<= 1 width 512) (<= 1 height 512) (< xhot width) (< yhot height) + (not (cffi:null-pointer-p pixels))) + (error "Invalid cursor dimensions or hotspot.")) + (let ((copy (make-array (list height width) :element-type '(unsigned-byte 32)))) + (dotimes (index (* width height)) + (setf (row-major-aref copy index) (cffi:mem-aref pixels :uint32 index))) + (make-cursor-frame :pixels copy :xhot xhot :yhot yhot :delay (max 1 delay)))))))) + +(defun %load-cursor-frames (names theme size) + (%ensure-cursor-library) + (dolist (name names) + (let ((images (%xcursor-load-images name theme size))) + (unless (cffi:null-pointer-p images) + (return-from %load-cursor-frames + (unwind-protect (values (%copy-native-cursor-frames images) name) + (%xcursor-free-images images)))))) + (error "No cursor ~S in theme ~S or its Xcursor fallbacks." names theme)) + +(defun %make-core-cursor (backend glyph) + (let ((font (xlib:open-font (x11-backend-display backend) "cursor"))) + (unwind-protect + (xlib:create-glyph-cursor + :source-font font :source-char glyph :mask-font font :mask-char (1+ glyph) + :foreground (xlib:make-color :red 0 :green 0 :blue 0) + :background (xlib:make-color :red 1 :green 1 :blue 1)) + (xlib:close-font font)))) + +(defun %make-render-cursor-frame (backend frame format) + (let* ((pixels (cursor-frame-pixels frame)) + (pixmap nil) (gc nil) (picture nil) (cursor nil) (success nil)) + (unwind-protect + (progn + (setf pixmap (xlib:create-pixmap :drawable (x11-backend-root backend) :depth 32 + :width (array-dimension pixels 1) :height (array-dimension pixels 0)) + gc (xlib:create-gcontext :drawable pixmap)) + (xlib:put-image pixmap gc (xlib:create-image :data pixels :depth 32 :bits-per-pixel 32) :x 0 :y 0) + (setf picture (xlib:render-create-picture pixmap :format format) + ;; CLX provides these RENDER requests but does not export them. + cursor (xlib::render-create-cursor picture (cursor-frame-xhot frame) (cursor-frame-yhot frame))) + (xlib:display-finish-output (x11-backend-display backend)) + (setf success t) + cursor) + (when (and cursor (not success)) (xlib:free-cursor cursor)) + (when picture (xlib:render-free-picture picture)) + (when gc (xlib:free-gcontext gc)) + (when pixmap (xlib:free-pixmap pixmap))))) + +(defun %make-themed-cursor (backend names theme size) + (let ((display (x11-backend-display backend))) + (unless (xlib:query-extension display "RENDER") (error "X server has no RENDER extension.")) + (multiple-value-bind (major minor) (xlib:render-query-version display) + (unless (or (plusp major) (>= minor 5)) (error "X server lacks ARGB cursor support.")) + (let ((format (xlib:find-standard-picture-format display :argb32))) + (unless format (error "X server has no ARGB32 picture format.")) + (multiple-value-bind (frames name) (%load-cursor-frames names theme size) + (let* ((animated-p (and (rest frames) (or (plusp major) (>= minor 8)))) + (used-frames (if animated-p frames (list (first frames)))) + (cursors nil) (result nil) (success nil)) + (unwind-protect + (progn + (dolist (frame used-frames) (push (%make-render-cursor-frame backend frame format) cursors)) + (setf cursors (nreverse cursors) + result (if animated-p + (xlib::render-create-anim-cursor cursors (mapcar #'cursor-frame-delay used-frames)) + (first cursors))) + (xlib:display-finish-output display) + (setf success t) + (values result (list :source :theme :name name :frames (length used-frames) + :width (array-dimension (cursor-frame-pixels (first frames)) 1) + :height (array-dimension (cursor-frame-pixels (first frames)) 0)))) + (dolist (cursor cursors) + (unless (and success (eq cursor result)) (xlib:free-cursor cursor))) + (when (and (not success) result (not (member result cursors))) (xlib:free-cursor result))))))))) + +(defun %load-pointer-cursor (backend names glyph theme size) + (let ((reason "Core cursors explicitly requested.")) + (unless (eq theme :core) + (handler-case (return-from %load-pointer-cursor (%make-themed-cursor backend names theme size)) + (error (condition) (setf reason (princ-to-string condition))))) + (values (%make-core-cursor backend glyph) (list :source :core :reason reason)))) + +(defstruct x11-cursor-set arrow hand report) + +(defun x11-backend-root-cursor (backend) + (let ((set (x11-backend-cursor-set backend))) (and set (x11-cursor-set-arrow set)))) +(defun x11-backend-hand-cursor (backend) + (let ((set (x11-backend-cursor-set backend))) (and set (x11-cursor-set-hand set)))) + +(defun %free-cursor-set (set) + (when set + (when (x11-cursor-set-arrow set) (xlib:free-cursor (x11-cursor-set-arrow set))) + (when (x11-cursor-set-hand set) (xlib:free-cursor (x11-cursor-set-hand set))) + (setf (x11-cursor-set-arrow set) nil (x11-cursor-set-hand set) nil))) + +(defun %prepare-cursor-set (backend style) + "Prepare a complete replacement without touching any displayed cursor." + (multiple-value-bind (theme size) (%backend-cursor-settings backend style) + (let ((set (make-x11-cursor-set)) (success nil)) + (unwind-protect + (progn + (multiple-value-bind (cursor info) (%load-pointer-cursor backend '("left_ptr" "default") 68 theme size) + (setf (x11-cursor-set-arrow set) cursor + (x11-cursor-set-report set) (list :theme theme :size size :arrow info))) + (multiple-value-bind (cursor info) (%load-pointer-cursor backend '("hand2" "pointer") 60 theme size) + (setf (x11-cursor-set-hand set) cursor (getf (x11-cursor-set-report set) :hand) info)) + (xlib:display-finish-output (x11-backend-display backend)) + (setf success t) + set) + (unless success (%free-cursor-set set)))))) + +(declaim (ftype function %refresh-ui-cursors)) +(defun %install-cursor-set (backend set) + (setf (x11-backend-cursor-set backend) set + (xlib:window-cursor (x11-backend-root backend)) (if set (x11-cursor-set-arrow set) :none)) + (%refresh-ui-cursors backend)) + +(defun %initialize-pointer-cursors (backend) + (%install-cursor-set backend (%prepare-cursor-set backend (make-ui-cursor-style)))) + +(defun %shutdown-pointer-cursors (backend) + (setf (xlib:window-cursor (x11-backend-root backend)) :none) + (%free-cursor-set (x11-backend-cursor-set backend)) + (setf (x11-backend-cursor-set backend) nil)) + +(defun backend-cursor-report (backend) + "Report requested/resolved settings and per-role themed/core fallback details. + +THEME is the search theme, not necessarily the source of the file: Xcursor +handles inherited themes and the system default when a requested asset is absent." + (let ((set (x11-backend-cursor-set backend))) + (and set (append (copy-tree (x11-cursor-set-report set)) + (list :session (%cursor-session-report backend)))))) diff --git a/src/x11/default-bindings.lisp b/src/x11/default-bindings.lisp new file mode 100644 index 0000000..cd53a06 --- /dev/null +++ b/src/x11/default-bindings.lisp @@ -0,0 +1,177 @@ +(in-package #:lime.x11) + +;;;; Configurable starter keymap +;;; +;;; INPUT owns passive grabs and dispatch. This optional layer is only a +;;; collection of command-layer choices: it carries no X11 event knowledge, +;;; Activity state, or lease policy of its own. Its generic bindings make a +;;; fresh Lime session usable while the small named-binding helpers leave +;;; Activity/View naming entirely to the user's Lisp configuration. + +(defun %default-modifiers (modifiers extra) + (typecase modifiers + (integer + (logior modifiers + (if extra + (apply #'xlib:make-state-mask extra) + 0))) + (list (append modifiers extra)) + (otherwise + (error 'invalid-transition + :description "Default keymap modifiers must be an integer mask or modifier list.")))) + +(defun bind-head-key (backend key head-id + &key (modifiers '(:mod-4)) description) + "Bind KEY to select HEAD-ID using MODIFIERS. + +This is deliberately a thin named configuration helper rather than part of +the universal starter keymap: physical output names belong to user config." + (bind-key backend key modifiers + (lambda (bound-backend) + (backend-select-head bound-backend head-id)) + :description (or description + (format nil "Select Head ~A" head-id)))) + +(defun bind-view-key (backend key view-id + &key (modifiers '(:mod-4)) + (policy :strict) description) + "Bind KEY to activate VIEW-ID with an explicit lease collision POLICY. + +POLICY is :STRICT, :PARTIAL, or :TAKE. Strict is the safe default; a future +interactive picker can preflight and present all three choices." + (bind-key backend key modifiers + (lambda (bound-backend) + (backend-activate-view bound-backend view-id :policy policy)) + :description (or description + (format nil "Open View ~A (~(~A~))" view-id policy)))) + +(defun bind-viewset-key (backend key viewset-id + &key (modifiers '(:mod-4)) + (policy :strict) description) + "Bind KEY to atomically recall VIEWSET-ID with explicit collision POLICY. + +Unlike BIND-VIEW-KEY, this operation targets every Head named by the saved +Viewset. It is intentionally opt-in configuration: personal work-desk and +game-desk names should remain Lisp data, not universal default bindings." + (bind-key backend key modifiers + (lambda (bound-backend) + (backend-activate-viewset bound-backend viewset-id :policy policy)) + :description (or description + (format nil "Open Viewset ~A (~(~A~))" + viewset-id policy)))) + +(defun bind-activity-key (backend key activity-id + &key view-id (modifiers '(:mod-4)) + (policy :strict) description) + "Bind KEY to open ACTIVITY-ID's live draft, or supplied VIEW-ID. + +The command verifies that VIEW-ID belongs to ACTIVITY-ID. Omitting it resumes +the Activity's unsaved Head-local draft, creating a blank draft when needed." + (bind-key backend key modifiers + (lambda (bound-backend) + (backend-activate-activity bound-backend activity-id + :view-id view-id :policy policy)) + :description (or description + (format nil "Open Activity ~A" activity-id)))) + +(defun install-default-keybindings + (backend &key (modifiers '(:mod-4)) (clear-existing-p nil)) + "Install Lime's small generic Super keymap and return its bindings. + +The default keymap deliberately has no Activity, View, or physical Head names: +use BIND-ACTIVITY-KEY, BIND-VIEW-KEY, and BIND-HEAD-KEY for those personal +choices. Its generic keys follow the user's existing dwm muscle memory. Set +CLEAR-EXISTING-P to remove a prior configuration before this keymap is +installed. + + Super-1..9,0 select Activity slot 1..10 + Super-Shift-1..9,0 select local View slot 1..10 + Super-t / Super-h focus next / previous visible client + Super-Shift-t / Super-Shift-h move focused tiled client forward / backward + Super-Return / Super-z promote / focus primary tiled client + Super-Shift-Return launch st + Super-b launch Waterfox + Super-Tab / Super-Shift-Tab cycle layout forward / backward + Super-d / Super-n shrink / grow master area + Super-Up / Super-Down add / remove a master client (minimum one) + Super-space toggle focused client float + Super-f toggle focused client fullscreen + Super-i / Super-Shift-i show hidden window / hide focused window + Super-Shift-c close focused client + Super-Shift-q quit Lime cleanly + Super-Shift-s update the mounted saved View + Super-p launch a PATH program (dmenu_run-like picker) + Super-y open the Activity/View command palette + Super-e / Super-Shift-e select next Head / send client to next Head" + (when clear-existing-p + (clear-keybindings backend)) + (flet ((bind (key extra handler description) + (bind-key backend key (%default-modifiers modifiers extra) + handler :description description))) + (append + (loop for slot from 1 to 10 for key across "1234567890" append + (let ((number slot)) + (list (bind key '() (lambda (b) (backend-select-activity-slot b number)) + (format nil "Select Activity slot ~D" number)) + (bind key '(:shift) (lambda (b) (backend-select-view-slot b number)) + (format nil "Select local View slot ~D" number))))) + (list + (bind #\t '() #'backend-focus-next-client "Focus next visible client") + (bind #\h '() #'backend-focus-previous-client "Focus previous visible client") + (bind #\t '(:shift) (lambda (bound-backend) + (backend-swap-focused-client bound-backend + :direction :next)) + "Move focused tiled client forward") + (bind #\h '(:shift) (lambda (bound-backend) + (backend-swap-focused-client bound-backend + :direction :previous)) + "Move focused tiled client backward") + ;; In Common Lisp #\Newline names the line-feed character, which CLX + ;; maps to X11's Linefeed keysym (not the physical Return key). Use + ;; #\Return explicitly for the normal main-keyboard Return binding. + (bind #\Return '() #'backend-promote-focused-client + "Promote focused client to master") + (bind #\z '() #'backend-focus-master-client "Focus primary tiled client") + (bind #\Return '(:shift) #'backend-launch-terminal + "Launch terminal (st)") + (bind #\b '() #'backend-launch-browser "Launch browser (Waterfox)") + (bind #\Tab '() (lambda (bound-backend) + (backend-cycle-layout bound-backend :direction :next)) + "Cycle layout forward") + (bind #\Tab '(:shift) (lambda (bound-backend) + (backend-cycle-layout bound-backend :direction :previous)) + "Cycle layout backward") + (bind #\d '() (lambda (bound-backend) + (backend-adjust-master-stack-ratio bound-backend (- 1/20))) + "Shrink master area") + (bind #\n '() (lambda (bound-backend) + (backend-adjust-master-stack-ratio bound-backend 1/20)) + "Grow master area") + (bind #xFF52 '() (lambda (bound-backend) + (backend-adjust-master-stack-count bound-backend 1)) + "Add master client") + (bind #xFF54 '() (lambda (bound-backend) + (backend-adjust-master-stack-count bound-backend -1)) + "Remove master client") + (bind #\Space '() #'backend-toggle-focused-client-floating + "Toggle focused client floating") + (bind #\f '() #'backend-toggle-focused-client-fullscreen + "Toggle focused client fullscreen") + (bind #\i '() #'backend-open-hidden-client-picker + "Show a hidden window from this Activity") + (bind #\i '(:shift) #'backend-hide-focused-client + "Hide focused window in this Activity") + (bind #\c '(:shift) #'backend-close-focused-client "Close focused client") + (bind #\q '(:shift) #'backend-request-quit "Quit Lime cleanly") + (bind #\s '(:shift) #'backend-open-view-update-picker + "Choose a saved view to replace") + (bind #\p '() #'backend-open-run-prompt "Launch PATH program") + (bind #\y '() #'backend-open-command-palette + "Open Activity/View command palette") + (bind #\e '() (lambda (bound-backend) + (backend-select-relative-head bound-backend :next)) + "Select next Head") + (bind #\e '(:shift) (lambda (bound-backend) + (backend-send-focused-client-relatively + bound-backend :next)) + "Send focused client to next Head"))))) diff --git a/src/x11/development-package.lisp b/src/x11/development-package.lisp new file mode 100644 index 0000000..3da9d0d --- /dev/null +++ b/src/x11/development-package.lisp @@ -0,0 +1,33 @@ +(defpackage #:lime.dev + (:use #:cl) + (:documentation + "Development runtime for a live Lime X11 session. + +The package deliberately keeps the production adapter free of Slynk and +threading policy. Its public calls serialize REPL work onto Lime's X event +thread, which is the only supported way to inspect or change a live backend +while the developer event loop is running.") + (:export + #:development-session + #:development-session-backend + #:development-session-repl-port + #:development-session-event-thread + #:development-session-reload-generation + #:development-session-last-reload-report + #:development-reload-report + #:development-reload-report-system + #:development-reload-report-success-p + #:development-reload-report-generation + #:development-reload-report-condition + #:*development-session* + #:start-development-session + #:run-development-session + #:stop-development-session + #:restart-development-session + #:resume-development-session + #:save-development-session + #:call-in-development-session + #:with-development-backend + #:reload-development-code + #:reload-development-configuration + #:development-status)) diff --git a/src/x11/development.lisp b/src/x11/development.lisp new file mode 100644 index 0000000..cab71c9 --- /dev/null +++ b/src/x11/development.lisp @@ -0,0 +1,505 @@ +(in-package #:lime.dev) + +;;;; Live developer runtime +;;; +;;; A window manager owns a single X connection and mutates one model world. +;;; Slynk evaluates REPL requests on its own threads, so sending those requests +;;; straight to the backend would race the CLX event loop. This module keeps +;;; the normal adapter unopinionated and gives development sessions one small, +;;; explicit mailbox: all supported live work runs at an event-loop boundary. + +(defstruct development-request + function + values + failure + (completed-p nil)) + +(defstruct development-reload-report + "Outcome of one source reload attempted by RELOAD-DEVELOPMENT-CODE." + system + generation + (success-p nil) + condition) + +(defstruct (development-session (:constructor %make-development-session)) + "One running Lime backend plus its developer control boundary." + backend + start-arguments + repl-port + (repl-running-p nil) + event-timeout + event-thread + ;; The mailbox protects only request bookkeeping. Request functions always + ;; run outside this lock, on the X event thread, so they may safely invoke + ;; normal adapter commands and configuration reloads. + (lock (bt:make-lock "Lime development session")) + ;; Separate from mailbox bookkeeping: stop/restart join the owner thread, + ;; which still needs the mailbox lock while draining pending requests. + (lifecycle-lock (bt:make-lock "Lime development lifecycle")) + (condition-variable (bt:make-condition-variable :name "Lime development requests")) + (pending-requests '()) + (running-p nil) + (paused-p nil) + (restarting-p nil) + event-loop-condition + diagnostic-file + diagnostic-write-error + last-error-report + (reload-generation 0) + last-reload-report) + +(defvar *development-session* nil + "The one developer session started in this Lisp image, if any.") + +(defun %development-session-or-error (session) + (or session *development-session* + (error "No Lime development session is running in this Lisp image."))) + +(defun %plist-without (arguments removed-keys) + (loop for (key value) on arguments by #'cddr + unless (member key removed-keys) + append (list key value))) + +(defun %enqueue-development-request (session request) + (bt:with-lock-held ((development-session-lock session)) + (unless (and (development-session-running-p session) + (not (development-session-restarting-p session))) + (error "The Lime development session is not accepting requests.")) + (push request (development-session-pending-requests session))) + request) + +(defun %take-development-requests (session) + (bt:with-lock-held ((development-session-lock session)) + (prog1 (nreverse (development-session-pending-requests session)) + (setf (development-session-pending-requests session) '())))) + +(defun %complete-development-request (session request values failure) + (bt:with-lock-held ((development-session-lock session)) + (setf (development-request-values request) values + (development-request-failure request) failure + (development-request-completed-p request) t) + (bt:condition-notify (development-session-condition-variable session))) + request) + +(defun %service-development-requests (session backend) + "Run every queued developer operation on Lime's X event thread." + (dolist (request (%take-development-requests session)) + (handler-case + (%complete-development-request + session request + (multiple-value-list + (funcall (development-request-function request) backend)) + nil) + (error (condition) + (%complete-development-request session request nil condition))))) + +(defun %fail-pending-development-requests (session condition) + (dolist (request (%take-development-requests session)) + (%complete-development-request session request nil condition))) + +(defun %default-diagnostic-file (display-name) + (merge-pathnames + (format nil "lime/last-error-~A.log" + (map 'string (lambda (c) (if (alphanumericp c) c #\-)) + (or display-name "default"))) + (uiop:ensure-directory-pathname + (or (let ((path (uiop:getenv "XDG_STATE_HOME"))) + (and path (plusp (length path)) path)) + (merge-pathnames ".local/state/" (user-homedir-pathname)))))) + +(defun %error-backtrace () + #+sbcl (handler-case + (with-output-to-string (stream) + (let ((sb-debug:*debug-print-variable-alist* + '((*print-length* . 8) (*print-level* . 3) (*print-circle* . t)))) + ;; Function names and event context suffice here; don't dump + ;; session/model arguments or arbitrary user objects. + (sb-debug:print-backtrace :stream stream :count 30 :argument-limit 0 + :emergency-best-effort t))) + (error () "[Backtrace could not be printed]")) + #-sbcl nil) + +(defun %capture-session-error (session condition &optional (source :event-loop)) + "Capture before unwinding, while the failing event's stack is still available." + (setf (development-session-event-loop-condition session) condition + (development-session-last-error-report session) + (lime.x11:backend-record-diagnostic + (development-session-backend session) condition :source source + :backtrace (%error-backtrace)))) + +(defun %write-session-diagnostic (session) + "Keep the last fault on disk, not an unbounded per-motion log. Failure is nonfatal." + (let ((path (development-session-diagnostic-file session))) + (when path + (handler-case + (progn + (ensure-directories-exist path) + (with-open-file (stream path :direction :output :if-exists :supersede + :if-does-not-exist :create :external-format :utf-8) + ;; Backtraces can contain user paths/data. Make the empty file + ;; private before writing any contents (Lime's X11 target is Unix). + (unless (zerop (cffi:foreign-funcall "chmod" :string (namestring path) + :unsigned-int #o600 :int)) + (error "Could not make Lime's diagnostic file private.")) + (let ((*print-pretty* t) (*print-readably* nil)) + (format stream "Lime paused; X and the Lisp control session are retained.~%~S~%" + (development-session-last-error-report session)))) + (setf (development-session-diagnostic-write-error session) nil)) + (error (condition) + (setf (development-session-diagnostic-write-error session) + (lime.x11::%diagnostic-condition-message condition))))))) + +(defun %pause-development-session (session condition) + "Do not stop the X session or retry potentially partial model mutations." + (setf (development-session-paused-p session) t + (development-session-event-loop-condition session) condition + (lime.x11::x11-backend-running-p (development-session-backend session)) nil) + (lime.x11:backend-release-input (development-session-backend session)) + (%write-session-diagnostic session) + (ignore-errors + (format *error-output* + "~&Lime paused after an error: ~A~%Diagnostic: ~A~%Use (lime.dev:development-status), then (lime.dev:resume-development-session) after repair.~%" + condition (or (development-session-diagnostic-file session) "in-memory only"))) + session) + +(defun %run-development-event-loop (session) + (loop while (development-session-running-p session) + do (if (development-session-paused-p session) + (progn + ;; The same owner thread remains available for inspection, + ;; source/config repair, resume, or an explicit quit request. + (%service-development-requests session (development-session-backend session)) + (when (lime.x11::x11-backend-quit-requested-p (development-session-backend session)) + (setf (development-session-running-p session) nil)) + (sleep (development-session-event-timeout session))) + (handler-case + (progn + (handler-bind ((error (lambda (condition) + (%capture-session-error session condition)))) + (lime.x11:run-event-loop + (development-session-backend session) + :timeout (development-session-event-timeout session) + :before-event + (lambda (backend) (%service-development-requests session backend)))) + ;; Only a normal return (explicit quit/stop) ends the owner. + (setf (development-session-running-p session) nil)) + (error (condition) (%pause-development-session session condition))))) + (%fail-pending-development-requests + session (make-condition 'simple-error :format-control "Lime event loop stopped.")) + session) + +(defun %start-slynk (port) + "Start a loopback-only Slynk server and return PORT." + ;; LIME/DEV depends on Slynk while the normal Lime systems intentionally do + ;; not. The explicit interface prevents a development WM from listening on + ;; the LAN by accident. + (slynk:create-server :port port :dont-close t :interface "127.0.0.1") + port) + +(defun %stop-slynk (session) + (when (development-session-repl-running-p session) + (ignore-errors (slynk:stop-server (development-session-repl-port session))) + (setf (development-session-repl-running-p session) nil))) + +(defun start-development-session + (&rest arguments + &key + (repl-port 4005) + (start-repl-p t) + (event-timeout 0.05) + (session-file :default) + (diagnostic-file :default) + &allow-other-keys) + "Start Lime for interactive development and return a DEVELOPMENT-SESSION. + +All ordinary START-LIME keywords, including :DISPLAY-NAME and :CONFIG-FILE, +are accepted. SESSION-FILE defaults to :DEFAULT (display-specific autosave and +restore); pass NIL for a disposable session, or a pathname for a named desk. +The event loop runs in its own thread; with the default +START-REPL-P, Slynk listens only on 127.0.0.1:REPL-PORT. Use +WITH-DEVELOPMENT-BACKEND or CALL-IN-DEVELOPMENT-SESSION from that REPL instead +of invoking backend commands concurrently from an arbitrary Slynk thread." + (when (and *development-session* + (or (development-session-running-p *development-session*) + (development-session-restarting-p *development-session*))) + (error "A Lime development session is already running in this Lisp image.")) + (unless (and (integerp repl-port) (<= 1 repl-port 65535)) + (error "Lime's Slynk port must be an integer from 1 through 65535.")) + (unless (and (realp event-timeout) (plusp event-timeout)) + (error "Lime's developer event timeout must be positive.")) + (let* ((start-arguments + (append (%plist-without arguments '(:repl-port :start-repl-p :event-timeout :diagnostic-file :session-file)) + (list :session-file session-file))) + (backend (apply #'lime.x11:start-lime start-arguments)) + (session (%make-development-session + :backend backend + :start-arguments start-arguments + :repl-port repl-port + :event-timeout event-timeout + :diagnostic-file + (if (eq diagnostic-file :default) + (%default-diagnostic-file (lime.x11::x11-backend-display-name backend)) + (and diagnostic-file (pathname diagnostic-file))) + :running-p t))) + (handler-case + (progn + (when start-repl-p + (%start-slynk repl-port) + (setf (development-session-repl-running-p session) t)) + (setf (development-session-event-thread session) + (bt:make-thread (lambda () (%run-development-event-loop session)) + :name "Lime X11 event loop")) + (setf *development-session* session) + session) + (error (condition) + (%stop-slynk session) + (lime.x11:stop-backend backend :save-session-p nil) + (error condition))))) + +(defun %development-supervised-p (session) + (and session (or (development-session-running-p session) + (development-session-restarting-p session)))) + +(defun run-development-session (&rest arguments) + "Start a session and keep this Lisp process alive until it is stopped. + +Use this as the final form in an xinit/xsession launcher, where SBCL may have +no usable standard input and would otherwise exit after START-DEVELOPMENT- +SESSION returns. Interactive terminals normally want START-DEVELOPMENT-SESSION +instead, so their local REPL remains available too." + (let ((session (apply #'start-development-session arguments))) + (declare (ignore session)) + (unwind-protect + ;; Pauses and slow/failed explicit restarts must not end xinit. Only + ;; an intentional stop/quit releases the supervised session. + (loop while (%development-supervised-p *development-session*) + do (sleep 1)) + ;; A Slynk caller may already have stopped the current session. Do not + ;; attempt a second ownership handoff in that ordinary case. + (when *development-session* + (stop-development-session *development-session*))) + *development-session*)) + +(defun call-in-development-session (function &key session) + "Run FUNCTION with the live backend on its X event thread. + +FUNCTION receives one LIME.X11:X11-BACKEND and may use ordinary commands, +configuration reloads, or pure inspection. Multiple values and errors are +returned to the REPL caller. A call made by the event thread itself executes +directly, which keeps key bindings and palette actions free of queue latency." + (unless (functionp function) + (error "A development-session request must be a function.")) + (let ((session (%development-session-or-error session))) + (when (eq (bt:current-thread) (development-session-event-thread session)) + (return-from call-in-development-session + (funcall function (development-session-backend session)))) + (let ((request (make-development-request :function function))) + (%enqueue-development-request session request) + (bt:with-lock-held ((development-session-lock session)) + (loop until (development-request-completed-p request) + do (progn + ;; A short timeout means an unexpected event-loop death is + ;; observable even on thread implementations where a + ;; condition-notify raced a REPL wait. + (bt:condition-wait (development-session-condition-variable session) + (development-session-lock session) + :timeout 0.25) + (when (and (not (development-request-completed-p request)) + (or (not (development-session-running-p session)) + (let ((thread (development-session-event-thread session))) + (and thread (not (bt:thread-alive-p thread)))))) + (error (or (development-session-event-loop-condition session) + "The Lime development event loop stopped."))))) + (let ((failure (development-request-failure request))) + (if failure + (error failure) + (values-list (development-request-values request)))))))) + +(defmacro with-development-backend ((backend &optional session) &body body) + "Evaluate BODY with BACKEND serialized on the active Lime event thread." + `(call-in-development-session + (lambda (,backend) ,@body) + :session (or ,session *development-session*))) + +(defun %reloadable-development-system-p (system) + ;; These systems contain only the regular model/UI/X11 code. LIME/DEV owns + ;; the executing control loop and is intentionally restarted after editing + ;; its own mailbox/thread implementation. + (member (string-downcase (string system)) + '("lime" "lime/ui" "lime/x11") + :test #'string=)) + +(defun reload-development-code (&key (system "lime/x11") session (force-p nil)) + "Compile/load changed ordinary Lime source without replacing the live world. + +This is for function-level edits: commands, layouts, rendering, UI, and other +code that preserves existing structure layouts. Changing DEFSTRUCT slots, +package/load topology, thread ownership, or this LIME/DEV runtime itself is a +restart boundary; use RESTART-DEVELOPMENT-SESSION for those changes. A failed +compile returns a DEVELOPMENT-RELOAD-REPORT and leaves the existing backend +and event loop alive." + (unless (%reloadable-development-system-p system) + (error "~S is not a hot-reloadable Lime system; restart the developer session instead." + system)) + (let ((session (%development-session-or-error session))) + (call-in-development-session + (lambda (backend) + (handler-case + (progn + (asdf:load-system system :force force-p) + ;; Reconciliation makes a changed renderer, bar, or layout helper + ;; visible immediately without altering the Activity/View world. + (lime.x11:apply-active-presentation backend) + (let ((report + (make-development-reload-report + :system system + :generation (incf (development-session-reload-generation session)) + :success-p t))) + (setf (development-session-last-reload-report session) report) + report)) + (error (condition) + (let ((report + (make-development-reload-report + :system system + :generation (development-session-reload-generation session) + :success-p nil + :condition condition))) + (setf (development-session-last-reload-report session) report) + report)))) + :session session))) + +(defun reload-development-configuration (&key session) + "Reload the selected user configuration on the serialized X event thread." + (call-in-development-session + (lambda (backend) + (lime.x11:reload-backend-configuration backend)) + :session (%development-session-or-error session))) + +(defun save-development-session (&key session replace-invalid-p) + "Flush the current desk to disk through the serialized owner-thread boundary." + (call-in-development-session + (lambda (backend) (lime.x11:backend-save-session backend :replace-invalid-p replace-invalid-p)) + :session (%development-session-or-error session))) + +(defun development-status (&optional (session *development-session*)) + "Return developer-runtime state plus the ordinary backend status." + (let ((session (%development-session-or-error session))) + (list :running-p (development-session-running-p session) + :paused-p (development-session-paused-p session) + :restarting-p (development-session-restarting-p session) + :diagnostic-file (development-session-diagnostic-file session) + :diagnostic-write-error (development-session-diagnostic-write-error session) + :last-error-report (copy-tree (development-session-last-error-report session)) + :repl-port (and (development-session-repl-running-p session) + (development-session-repl-port session)) + :event-thread-alive-p + (and (development-session-event-thread session) + (bt:thread-alive-p (development-session-event-thread session))) + :reload-generation (development-session-reload-generation session) + :last-reload-report (development-session-last-reload-report session) + :event-loop-condition (development-session-event-loop-condition session) + :backend-status + (when (and (development-session-running-p session) + (not (development-session-restarting-p session))) + (handler-case + (call-in-development-session + (lambda (backend) + (append (lime.x11:backend-status backend) + (list :diagnostics (lime.x11:backend-diagnostics backend)))) + :session session) + (error (condition) (list :unavailable (lime.x11::%diagnostic-condition-message condition)))))))) + +(defun resume-development-session (&optional (session *development-session*)) + "Try to resume the existing world after repair; failed validation stays paused." + (let ((session (%development-session-or-error session))) + (call-in-development-session + (lambda (backend) + (when (development-session-paused-p session) + (handler-case + (handler-bind ((error (lambda (condition) + (%capture-session-error session condition :resume)))) + (lime.x11:backend-reconcile-after-error backend) + (setf (development-session-paused-p session) nil + (development-session-event-loop-condition session) nil)) + (error (condition) + (%write-session-diagnostic session) + (error condition))))) + :session session) + session)) + +(defun stop-development-session (&optional (session *development-session*)) + "Stop the event thread, remap clients, close Slynk, and release the X server." + (let ((session (%development-session-or-error session))) + (when (eq (bt:current-thread) (development-session-event-thread session)) + (error "Stop Lime's developer session from its control REPL, not its X event thread.")) + (bt:with-lock-held ((development-session-lifecycle-lock session)) + ;; Let the event loop leave at its next timeout before closing CLX. Closing + ;; the display first would make a concurrent EVENT-CASE an avoidable race. + (setf (development-session-running-p session) nil + (lime.x11::x11-backend-running-p (development-session-backend session)) nil) + (let ((thread (development-session-event-thread session))) + (when thread + (bt:join-thread thread))) + (%fail-pending-development-requests + session (make-condition 'simple-error :format-control "Lime development session stopped.")) + (%stop-slynk session) + (lime.x11:stop-backend (development-session-backend session) + :save-session-p (not (development-session-paused-p session))) + (when (eq *development-session* session) + (setf *development-session* nil)) + session))) + +(defun restart-development-session (&optional (session *development-session*)) + "Explicitly rebuild the backend, keeping xinit and Slynk alive even if startup fails. + +Unlike RESUME-DEVELOPMENT-SESSION, this constructs a new backend/world from the +session file when enabled, reconnecting surviving windows. With persistence +disabled it starts fresh. It never relaunches applications or their X server." + (let ((session (%development-session-or-error session))) + (when (eq (bt:current-thread) (development-session-event-thread session)) + (error "Restart from the control REPL, not the X event thread.")) + (bt:with-lock-held ((development-session-lifecycle-lock session)) + (bt:with-lock-held ((development-session-lock session)) + (when (development-session-restarting-p session) + (error "A Lime restart is already in progress.")) + (unless (development-session-running-p session) + (error "This Lime session has stopped; start a new session instead.")) + (setf (development-session-restarting-p session) t + (development-session-running-p session) nil + (lime.x11::x11-backend-running-p (development-session-backend session)) nil)) + (when (development-session-event-thread session) + (bt:join-thread (development-session-event-thread session))) + (unwind-protect + (handler-case + (progn + ;; Abort a normal restart before closing X if the latest desk + ;; cannot be saved. Retrying that failed save may snapshot the + ;; still-live backend; an event-loop fault instead uses the + ;; last good disk snapshot, not a possibly partial mutation. + (when (and (lime.x11::x11-backend-display (development-session-backend session)) + (getf (lime.x11:backend-session-status (development-session-backend session)) :enabled-p) + (or (not (development-session-paused-p session)) + (eq :restart (getf (development-session-last-error-report session) :source)))) + (lime.x11:backend-save-session (development-session-backend session))) + (lime.x11:stop-backend (development-session-backend session) + :save-session-p nil) + (setf (development-session-backend session) + (apply #'lime.x11:start-lime (development-session-start-arguments session)) + (development-session-paused-p session) nil + (development-session-event-loop-condition session) nil)) + (error (condition) + (%capture-session-error session condition :restart) + (setf (development-session-paused-p session) t) + ;; A pre-restart save can fail while the old X connection is + ;; still live. Do not leave a menu/drag grab trapping input. + (lime.x11:backend-release-input (development-session-backend session)) + (%write-session-diagnostic session) + (error condition))) + ;; Even failed startup leaves a control mailbox/Slynk session to retry + ;; from, rather than returning from xinit and killing every application. + (setf (development-session-running-p session) t + (development-session-restarting-p session) nil + (development-session-event-thread session) + (bt:make-thread (lambda () (%run-development-event-loop session)) + :name "Lime X11 event loop"))) + session))) diff --git a/src/x11/ewmh.lisp b/src/x11/ewmh.lisp new file mode 100644 index 0000000..0c2cc25 --- /dev/null +++ b/src/x11/ewmh.lisp @@ -0,0 +1,472 @@ +(in-package #:lime.x11) + +;;;; Small EWMH compatibility boundary +;;; +;;; EWMH is deliberately adapter state. In particular, fullscreen is an +;;; application's temporary request to occupy the Head currently holding its +;;; Lease; it is neither a saved View layout nor a global desktop abstraction. +;;; That preserves Lime's Activity/View semantics while letting games and +;;; ordinary desktop clients use the protocol they expect. + +(defparameter +ewmh-supported-atoms+ + '(:_NET_SUPPORTED + :_NET_SUPPORTING_WM_CHECK + :_NET_WM_NAME + :_NET_CLIENT_LIST + :_NET_CLIENT_LIST_STACKING + :_NET_WM_STATE + :_NET_WM_STATE_FULLSCREEN + :_NET_WM_STATE_DEMANDS_ATTENTION + :_NET_ACTIVE_WINDOW + :_NET_CLOSE_WINDOW + :_NET_WM_WINDOW_TYPE + :_NET_WM_WINDOW_TYPE_NORMAL + :_NET_WM_WINDOW_TYPE_DIALOG + :_NET_WM_WINDOW_TYPE_UTILITY + :_NET_WM_WINDOW_TYPE_SPLASH + :_NET_WM_WINDOW_TYPE_DOCK + :_NET_WM_WINDOW_TYPE_DESKTOP) + "The deliberately small EWMH vocabulary Lime currently implements.") + +(defparameter +ewmh-window-type-atoms+ + '((:_NET_WM_WINDOW_TYPE_NORMAL . :normal) + (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog) + (:_NET_WM_WINDOW_TYPE_UTILITY . :utility) + (:_NET_WM_WINDOW_TYPE_SPLASH . :splash) + (:_NET_WM_WINDOW_TYPE_DOCK . :dock) + (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop)) + "Recognized EWMH window types and their adapter-local names.") + +(defparameter +ewmh-dialog-like-window-types+ '(:dialog :utility :splash) + "Types that receive Lime's default centered floating placement.") + +(defparameter +ewmh-external-window-types+ '(:dock :desktop) + "Types mapped outside Activities and Views rather than tiled as task clients.") + +(defparameter +ewmh-wm-name-utf8+ + (make-array 4 :element-type '(unsigned-byte 8) + :initial-contents '(76 105 109 101)) + "The ASCII/UTF-8 bytes for Lime's EWMH supporting-window name.") + +(defun %ewmh-atom-id (backend atom) + (xlib:intern-atom (x11-backend-display backend) atom)) + +(defun %ewmh-fullscreen-atom-id (backend) + (%ewmh-atom-id backend :_NET_WM_STATE_FULLSCREEN)) + +(defun %ewmh-window-type-atom-alist (backend) + "Return (TYPE . X-ATOM-ID) pairs for Lime's recognized type vocabulary." + (mapcar (lambda (entry) + (cons (cdr entry) (%ewmh-atom-id backend (car entry)))) + +ewmh-window-type-atoms+)) + +(defun %ewmh-types-from-atom-ids (atom-ids type-atom-alist) + "Decode ATOM-IDS using TYPE-ATOM-ALIST, defaulting to the EWMH normal type. + +TYPE-ATOM-ALIST is deliberately ordinary data so this policy can be tested +without a live X server. EWMH specifies Normal as the default when a client +does not publish _NET_WM_WINDOW_TYPE or publishes only unknown extensions." + (let ((types + (remove-duplicates + (loop for atom-id in atom-ids + for entry = (find atom-id type-atom-alist :key #'cdr :test #'eql) + when entry collect (car entry)) + :test #'eq))) + (or types '(:normal)))) + +(defun %ewmh-window-types-for-window (backend window) + "Read WINDOW's recognized EWMH types without changing task-model state." + (%ewmh-types-from-atom-ids + (copy-list (xlib:get-property window :_NET_WM_WINDOW_TYPE :type :ATOM)) + (%ewmh-window-type-atom-alist backend))) + +(defun ewmh-client-window-types (backend client-id) + "Return a copy of CLIENT-ID's recognized EWMH window types, if managed." + (let ((types (gethash client-id (x11-backend-ewmh-window-types backend)))) + (and types (copy-list types)))) + +(defun %ewmh-dialog-like-window-types-p (types) + (not (null (intersection types +ewmh-dialog-like-window-types+ :test #'eq)))) + +(defun %ewmh-external-window-types-p (types) + (not (null (intersection types +ewmh-external-window-types+ :test #'eq)))) + +(defun ewmh-client-dialog-like-p (backend client-id) + "Whether CLIENT-ID has an EWMH type deserving Lime's dialog placement." + (%ewmh-dialog-like-window-types-p (ewmh-client-window-types backend client-id))) + +(defun %ewmh-add-client-window-id (client-order window-id) + "Append WINDOW-ID once, preserving EWMH initial-map order." + (if (member window-id client-order :test #'eql) + client-order + (append client-order (list window-id)))) + +(defun %ewmh-remove-client-window-id (client-order window-id) + "Remove WINDOW-ID from an EWMH client order without disturbing the rest." + (remove window-id client-order :test #'eql)) + +(defun %ewmh-remember-client-window (backend window) + (setf (x11-backend-ewmh-client-order backend) + (%ewmh-add-client-window-id + (x11-backend-ewmh-client-order backend) (xlib:window-id window))) + window) + +(defun %ewmh-forget-client-window-id (backend window-id) + (setf (x11-backend-ewmh-client-order backend) + (%ewmh-remove-client-window-id + (x11-backend-ewmh-client-order backend) window-id)) + (remhash window-id (x11-backend-ewmh-external-windows backend)) + window-id) + +(defun %ewmh-known-client-window-id-p (backend window-id) + "Whether WINDOW-ID is one of Lime's task or external EWMH clients." + (or (gethash window-id (x11-backend-window-clients backend)) + (gethash window-id (x11-backend-ewmh-external-windows backend)))) + +(defun %ewmh-live-client-order (backend) + "Filter stale ids before publishing EWMH's initial-map-order list." + (setf (x11-backend-ewmh-client-order backend) + (remove-if-not (lambda (window-id) + (%ewmh-known-client-window-id-p backend window-id)) + (x11-backend-ewmh-client-order backend)))) + +(defun %ewmh-stacking-client-order (backend) + "Read current root-child stacking order, filtered to EWMH client windows." + (multiple-value-bind (children parent root) + (xlib:query-tree (x11-backend-root backend)) + (declare (ignore parent root)) + (loop for window in children + for window-id = (xlib:window-id window) + when (%ewmh-known-client-window-id-p backend window-id) + collect window-id))) + +(defun %ewmh-write-window-list (root property window-ids) + (if window-ids + (xlib:change-property root property window-ids :WINDOW 32) + (xlib:delete-property root property))) + +(defun ewmh-sync-client-lists (backend) + "Publish accurate EWMH client and stacking lists for task and dock windows." + (when (x11-backend-display backend) + (let ((root (x11-backend-root backend))) + (%ewmh-write-window-list root :_NET_CLIENT_LIST + (%ewmh-live-client-order backend)) + (%ewmh-write-window-list root :_NET_CLIENT_LIST_STACKING + (%ewmh-stacking-client-order backend)))) + backend) + +(defun ewmh-adopt-client (backend client-id window) + "Cache WINDOW's EWMH types and add it to Lime's EWMH client inventory." + (setf (gethash client-id (x11-backend-ewmh-window-types backend)) + (%ewmh-window-types-for-window backend window)) + (%ewmh-remember-client-window backend window) + (%attention-refresh-client backend client-id window) + (ewmh-sync-client-lists backend) + client-id) + +(defun ewmh-adopt-external-window (backend window types) + "Map a dock/desktop WINDOW without turning it into an Activity task client. + +External surfaces retain the geometry supplied by their own application. A +later strut/work-area pass can build on this separation without teaching the +core model about panels or wallpapers." + (let ((window-id (xlib:window-id window))) + (setf (gethash window-id (x11-backend-ewmh-external-windows backend)) window) + (%ewmh-remember-client-window backend window) + (xlib:map-window window) + (setf (xlib:window-priority window) + (if (member :dock types) :above :below)) + (ewmh-sync-client-lists backend) + window)) + +(defun ewmh-external-window-p (backend window) + "Whether WINDOW is an adapter-owned dock or desktop surface." + (not (null (gethash (xlib:window-id window) + (x11-backend-ewmh-external-windows backend))))) + +(defun %ewmh-configure-request-includes-p (value-mask component) + "Whether a raw X ConfigureRequest VALUE-MASK contains COMPONENT." + (logbitp (ecase component + (:x 0) + (:y 1) + (:width 2) + (:height 3) + (:border-width 4)) + value-mask)) + +(defun ewmh-handle-external-configure-request + (backend window x y width height border-width value-mask) + "Honor geometry requests from an external dock/desktop WINDOW only. + +SubstructureRedirect sends every top-level ConfigureRequest to Lime. Regular +task clients remain model-controlled; external EWMH surfaces own their own +geometry until a later strut/work-area policy deliberately constrains them." + (when (ewmh-external-window-p backend window) + (xlib:with-state (window) + (when (%ewmh-configure-request-includes-p value-mask :x) + (setf (xlib:drawable-x window) x)) + (when (%ewmh-configure-request-includes-p value-mask :y) + (setf (xlib:drawable-y window) y)) + (when (%ewmh-configure-request-includes-p value-mask :width) + (setf (xlib:drawable-width window) (max 1 width))) + (when (%ewmh-configure-request-includes-p value-mask :height) + (setf (xlib:drawable-height window) (max 1 height))) + (when (%ewmh-configure-request-includes-p value-mask :border-width) + (setf (xlib:drawable-border-width window) border-width))) + (ewmh-sync-client-lists backend) + t)) + +(defun ewmh-forget-external-window (backend window) + "Forget a withdrawn or destroyed adapter-owned external EWMH surface." + (when (ewmh-external-window-p backend window) + (%ewmh-forget-client-window-id backend (xlib:window-id window)) + (ewmh-sync-client-lists backend)) + window) + +(defun %ewmh-window-state-atoms (window) + "Return WINDOW's current _NET_WM_STATE atom ids without interpreting them. + +Unknown state atoms remain intact whenever Lime changes fullscreen. We do not +claim to implement maximization, above, sticky, or other state merely because +a client happens to carry those atoms." + (copy-list (xlib:get-property window :_NET_WM_STATE :type :ATOM))) + +(defun %ewmh-set-window-state-atom (backend window atom enabled-p) + "Change just ATOM, preserving unrelated state and avoiding redundant notifications." + (let* ((atom-id (xlib:intern-atom (x11-backend-display backend) atom)) + (old-atoms (%ewmh-window-state-atoms window)) + (other-atoms (remove atom-id old-atoms + :test #'eql)) + (atoms (if enabled-p + (cons atom-id other-atoms) + other-atoms))) + (unless (equal atoms old-atoms) + (if atoms + (xlib:change-property window :_NET_WM_STATE atoms :ATOM 32) + (xlib:delete-property window :_NET_WM_STATE)))) + enabled-p) + +(defun %set-ewmh-window-fullscreen-property (backend window fullscreen-p) + (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_FULLSCREEN fullscreen-p) + fullscreen-p) + +(defun ewmh-client-fullscreen-p (backend client-id) + "Whether CLIENT-ID has requested Lime's supported fullscreen state." + (not (null (gethash client-id (x11-backend-fullscreen-clients backend))))) + +(defun %ewmh-active-presentation-for-client (backend client-id) + "Return CLIENT-ID's active Presentation, or NIL while it is parked. + +The model's exclusive Lease is the authoritative answer. This helper has no +separate monitor bookkeeping, which is what keeps fullscreen compatible with +View activation and explicit cross-Head lease transfers." + (let ((lease (lease-for-client (x11-backend-world backend) client-id))) + (when lease + (let ((presentation (find-presentation + (x11-backend-world backend) + (lease-presentation-id lease)))) + (and (presentation-active-p (x11-backend-world backend) presentation) + presentation))))) + +(defun ewmh-active-head-id-for-client (backend client-id) + "Return the active Head currently displaying CLIENT-ID, if any." + (let ((presentation (%ewmh-active-presentation-for-client backend client-id))) + (and presentation (presentation-head-id presentation)))) + +(defun ewmh-fullscreen-client-id-for-head (backend head-id) + "Return HEAD-ID's currently visible fullscreen client, if one exists. + +The lease/presentation placement order makes this deterministic even if two +old hidden Views later meet in one draft. Normal fullscreen requests clear +every prior visible request on their Head, so that fallback is only defensive." + (let ((presentation (current-presentation (x11-backend-world backend) head-id))) + (when presentation + (find-if (lambda (client-id) (ewmh-client-fullscreen-p backend client-id)) + (presentation-leased-client-ids + (x11-backend-world backend) presentation))))) + +(defun ewmh-active-fullscreen-client-ids (backend) + "Return fullscreen clients visible on configured Heads in Head order." + (loop for head-id in (x11-backend-head-ids backend) + for client-id = (ewmh-fullscreen-client-id-for-head backend head-id) + when client-id collect client-id)) + +(defun ewmh-window-requests-fullscreen-p (backend window) + "Recognize an initial _NET_WM_STATE_FULLSCREEN property during adoption." + (member (%ewmh-fullscreen-atom-id backend) + (%ewmh-window-state-atoms window) + :test #'eql)) + +(defun %ewmh-clear-visible-fullscreen-on-head (backend head-id except-client-id) + (let ((presentation (current-presentation (x11-backend-world backend) head-id))) + (when presentation + (dolist (client-id (presentation-leased-client-ids + (x11-backend-world backend) presentation)) + (when (and (not (equal client-id except-client-id)) + (ewmh-client-fullscreen-p backend client-id)) + (ewmh-set-client-fullscreen-state backend client-id nil)))))) + +(defun ewmh-set-client-fullscreen-state (backend client-id fullscreen-p) + "Update EWMH fullscreen state without choosing focus or rendering. + +This is the protocol primitive. The public command layer decides whether the +request should select a visible client and then reconciles the display, while +the event handler can share precisely the same operation." + (let ((window (gethash client-id (x11-backend-client-windows backend)))) + (unless window + (error 'invalid-transition + :description (format nil "Client ~S has no managed X11 window." + client-id))) + (when fullscreen-p + (let ((head-id (ewmh-active-head-id-for-client backend client-id))) + (when head-id + (%ewmh-clear-visible-fullscreen-on-head backend head-id client-id)))) + (if fullscreen-p + (setf (gethash client-id (x11-backend-fullscreen-clients backend)) t) + (remhash client-id (x11-backend-fullscreen-clients backend))) + (%set-ewmh-window-fullscreen-property backend window fullscreen-p) + client-id)) + +(defun ewmh-forget-client (backend client-id &key window-id) + "Discard adapter-only EWMH state for a destroyed or withdrawn task client." + (remhash client-id (x11-backend-fullscreen-clients backend)) + (remhash client-id (x11-backend-attention-clients backend)) + (remhash client-id (x11-backend-ewmh-window-types backend)) + (when window-id + (%ewmh-forget-client-window-id backend window-id)) + (ewmh-sync-client-lists backend) + client-id) + +(defun ewmh-handle-property-notify (backend client-id window atom) + "Refresh EWMH metadata that Lime consumes when it changes after mapping." + (when (eq atom :_NET_WM_WINDOW_TYPE) + (setf (gethash client-id (x11-backend-ewmh-window-types backend)) + (%ewmh-window-types-for-window backend window))) + nil) + +(defun %ewmh-make-supporting-window (backend) + "Create the tiny self-referencing window required by _NET_SUPPORTING_WM_CHECK." + (xlib:create-window + :parent (x11-backend-root backend) + :x 0 :y 0 :width 1 :height 1 + :border-width 0 :override-redirect :on)) + +(defun ewmh-initialize (backend) + "Advertise Lime's EWMH surface and identify this WM to desktop clients." + (let* ((display (x11-backend-display backend)) + (root (x11-backend-root backend)) + (supporting-window (%ewmh-make-supporting-window backend)) + (supporting-window-id (xlib:window-id supporting-window))) + (setf (x11-backend-ewmh-supporting-window backend) supporting-window) + (xlib:change-property + root :_NET_SUPPORTED + (mapcar (lambda (atom) (xlib:intern-atom display atom)) + +ewmh-supported-atoms+) + :ATOM 32) + ;; EWMH requires both the root and this child to point at the same small + ;; window; _NET_WM_NAME is intentionally UTF-8 even though "Lime" is + ;; ASCII today. + (xlib:change-property root :_NET_SUPPORTING_WM_CHECK + (list supporting-window-id) :WINDOW 32) + (xlib:change-property supporting-window :_NET_SUPPORTING_WM_CHECK + (list supporting-window-id) :WINDOW 32) + ;; CLX sends an 8-bit property from an octet vector, not a Lisp string. + (xlib:change-property supporting-window :_NET_WM_NAME +ewmh-wm-name-utf8+ + :UTF8_STRING 8) + (ewmh-sync-client-lists backend)) + backend) + +(defun ewmh-shutdown (backend) + "Remove Lime-owned EWMH root properties and its supporting check window." + (let ((root (x11-backend-root backend))) + (xlib:delete-property root :_NET_ACTIVE_WINDOW) + (xlib:delete-property root :_NET_SUPPORTED) + (xlib:delete-property root :_NET_SUPPORTING_WM_CHECK) + (xlib:delete-property root :_NET_CLIENT_LIST) + (xlib:delete-property root :_NET_CLIENT_LIST_STACKING) + (when (x11-backend-ewmh-supporting-window backend) + (xlib:destroy-window (x11-backend-ewmh-supporting-window backend)) + (setf (x11-backend-ewmh-supporting-window backend) nil))) + backend) + +(defun ewmh-set-active-window (backend client-id) + "Publish CLIENT-ID as the EWMH input-focus target, or clear it for root." + (let ((window (and client-id + (gethash client-id (x11-backend-client-windows backend))))) + (if window + (xlib:change-property (x11-backend-root backend) :_NET_ACTIVE_WINDOW + (list (xlib:window-id window)) :WINDOW 32) + (xlib:delete-property (x11-backend-root backend) :_NET_ACTIVE_WINDOW))) + client-id) + +(defun %ewmh-state-action-result (action currently-fullscreen-p) + "Interpret the EWMH remove/add/toggle action code. + +The return value is CURRENTLY-FULLSCREEN-P for an unsupported action so a +malformed client message becomes a harmless no-op." + (case action + (0 nil) + (1 t) + (2 (not currently-fullscreen-p)) + (otherwise currently-fullscreen-p))) + +(defun %client-message-data-value (data index) + (and (< index (length data)) (aref data index))) + +(declaim (ftype function %attention-refresh-client %attention-request + backend-set-client-fullscreen + backend-focus-client + backend-close-client + apply-active-presentation)) + +(defun %ewmh-handle-window-state-message (backend window data) + (let ((client-id (%backend-client-id backend window)) + (fullscreen-atom (%ewmh-fullscreen-atom-id backend)) + (attention-atom (xlib:intern-atom (x11-backend-display backend) + :_NET_WM_STATE_DEMANDS_ATTENTION))) + (when (and client-id + (member (%client-message-data-value data 0) '(0 1 2)) + (or (eql (%client-message-data-value data 1) attention-atom) + (eql (%client-message-data-value data 2) attention-atom))) + (%attention-request + backend client-id + (%ewmh-state-action-result + (%client-message-data-value data 0) + (logtest 2 (gethash client-id (x11-backend-attention-clients backend) 0))))) + (when (and client-id + (or (eql (%client-message-data-value data 1) fullscreen-atom) + (eql (%client-message-data-value data 2) fullscreen-atom))) + (backend-set-client-fullscreen + backend client-id + (%ewmh-state-action-result + (%client-message-data-value data 0) + (ewmh-client-fullscreen-p backend client-id)))))) + +(defun %ewmh-handle-active-window-message (backend window) + (let ((client-id (%backend-client-id backend window))) + (when client-id + (let ((head-id (ewmh-active-head-id-for-client backend client-id))) + ;; A parked View remains parked. Automatically mounting it would be + ;; an implicit collision policy, so a client may only activate an + ;; already visible leased presentation through this small slice. + (if head-id + (backend-focus-client backend client-id :head-id head-id) + (%attention-request backend client-id t)))))) + +(defun %ewmh-handle-close-window-message (backend window) + (let ((client-id (%backend-client-id backend window))) + (when client-id + (backend-close-client backend client-id)))) + +(defun ewmh-handle-client-message (backend window type format data) + "Handle Lime's narrow supported set of EWMH client messages. + +The event loop has already established that this is a CLX client-message. We +accept only the 32-bit EWMH form and deliberately leave unknown protocol +requests alone instead of inventing fake desktop semantics." + (when (= format 32) + (case type + (:_NET_WM_STATE (%ewmh-handle-window-state-message backend window data)) + (:_NET_ACTIVE_WINDOW (%ewmh-handle-active-window-message backend window)) + (:_NET_CLOSE_WINDOW (%ewmh-handle-close-window-message backend window)))) + nil) diff --git a/src/x11/geometry.lisp b/src/x11/geometry.lisp new file mode 100644 index 0000000..8f8d7b5 --- /dev/null +++ b/src/x11/geometry.lisp @@ -0,0 +1,102 @@ +(in-package #:lime.x11) + +;;;; ICCCM geometry adaptation +;;; +;;; Lime's model owns desired Head-relative rectangles. This module adapts a +;;; resolved pixel rectangle to one client's WM_NORMAL_HINTS immediately before +;;; CLX configures it. Nothing here changes a View, Presentation, or Lease. + +(defun %geometry-positive-integer-or (value fallback) + (if (and (integerp value) (plusp value)) value fallback)) + +(defun %geometry-clamp (value minimum maximum) + (max minimum (min maximum value))) + +(defun %hinted-size (requested minimum maximum base increment hard-maximum) + "Return REQUESTED constrained to one ICCCM dimension. + +The normal-hint grid is BASE + N * INCREMENT. ICCCM clients normally publish +consistent min/max/base values; malformed or impossible declarations degrade +to the closest usable size, and an enclosing Head bound always wins over an +oversized minimum." + (let* ((upper-bound (%geometry-positive-integer-or hard-maximum + most-positive-fixnum)) + (hinted-minimum (%geometry-positive-integer-or minimum 1)) + (hinted-maximum (%geometry-positive-integer-or maximum upper-bound)) + (upper (min upper-bound hinted-maximum)) + ;; A client can demand more than an entire Head. The adapter cannot + ;; honor that without violating a Lime float's Head-local contract. + (lower (min upper (max 1 hinted-minimum))) + (size (%geometry-clamp (max 1 requested) lower upper)) + (step (%geometry-positive-integer-or increment 1)) + (anchor (if (integerp base) base (or minimum 0)))) + (if (= step 1) + size + (let* ((lowest-index (ceiling (- lower anchor) step)) + (highest-index (floor (- upper anchor) step))) + (if (> lowest-index highest-index) + size + (let ((index (%geometry-clamp + (floor (- size anchor) step) + lowest-index highest-index))) + (+ anchor (* step index)))))))) + +(defun constrain-geometry-to-normal-hints + (geometry normal-hints + &key bounds-x bounds-y bounds-width bounds-height) + "Return GEOMETRY adjusted to NORMAL-HINTS and optional enclosing bounds. + +Minimum/maximum dimensions and base-size resize increments are honored. When +BOUNDS-* describes a Head rectangle, the result is also kept inside it; this +is essential when a client advertises a minimum larger than a tile or Head. +Position changes only compensate for a size change that would otherwise leave +those explicit bounds." + (let* ((bounded-width (%geometry-positive-integer-or bounds-width + most-positive-fixnum)) + (bounded-height (%geometry-positive-integer-or bounds-height + most-positive-fixnum)) + (width (%hinted-size + (geometry-width geometry) + (and normal-hints (xlib:wm-size-hints-min-width normal-hints)) + (and normal-hints (xlib:wm-size-hints-max-width normal-hints)) + (and normal-hints (xlib:wm-size-hints-base-width normal-hints)) + (and normal-hints (xlib:wm-size-hints-width-inc normal-hints)) + bounded-width)) + (height (%hinted-size + (geometry-height geometry) + (and normal-hints (xlib:wm-size-hints-min-height normal-hints)) + (and normal-hints (xlib:wm-size-hints-max-height normal-hints)) + (and normal-hints (xlib:wm-size-hints-base-height normal-hints)) + (and normal-hints (xlib:wm-size-hints-height-inc normal-hints)) + bounded-height)) + (x (if bounds-x + (%geometry-clamp (geometry-x geometry) bounds-x + (+ bounds-x (- bounded-width width))) + (geometry-x geometry))) + (y (if bounds-y + (%geometry-clamp (geometry-y geometry) bounds-y + (+ bounds-y (- bounded-height height))) + (geometry-y geometry)))) + (make-geometry :x x :y y :width width :height height))) + +(defun constrain-client-geometry (backend client-id geometry &key head work-area) + "Adapt GEOMETRY to CLIENT-ID's cached ICCCM hints inside an adapter bound. + +HEAD retains the historical physical-rectangle convenience. WORK-AREA is the +preferred bound for normal tiled and floating clients now that a Head can +reserve its top bar; callers must choose at most one so fullscreen paths stay +visibly explicit." + (when (and head work-area) + (error 'invalid-transition + :description "Choose either a physical Head or a work area for client geometry.")) + (let ((info (backend-client-icccm-info backend client-id))) + (constrain-geometry-to-normal-hints + geometry (and info (icccm-client-info-normal-hints info)) + :bounds-x (cond (work-area (x11-work-area-x work-area)) + (head (x11-head-x head))) + :bounds-y (cond (work-area (x11-work-area-y work-area)) + (head (x11-head-y head))) + :bounds-width (cond (work-area (x11-work-area-width work-area)) + (head (x11-head-width head))) + :bounds-height (cond (work-area (x11-work-area-height work-area)) + (head (x11-head-height head)))))) diff --git a/src/x11/icccm.lisp b/src/x11/icccm.lisp new file mode 100644 index 0000000..315f5ec --- /dev/null +++ b/src/x11/icccm.lisp @@ -0,0 +1,231 @@ +(in-package #:lime.x11) + +;;;; ICCCM protocol boundary +;;; +;;; The Activity/View/Head model has no X atoms or client messages. This file +;;; owns those details: it snapshots the useful client properties, responds to +;;; property changes, and exposes protocol-aware focus, close, and Configure- +;;; Notify operations for the lifecycle and render layers. + +(defstruct icccm-client-info + "Cached ICCCM facts for one managed X11 client. + +The cache is backend-only: it is UI-facing metadata and protocol capability, +not durable Activity/View model state. NORMAL-HINTS remains the CLX +WM-SIZE-HINTS object so a later size-aware layout policy can consume the exact +client declaration without rereading X properties." + client-id + window-id + title + resource-name + resource-class + (protocols '()) + (accepts-input-p t) + (delete-window-p nil) + (take-focus-p nil) + transient-for-client-id + normal-hints + ;; This is a cache of what Lime last wrote to WM_STATE. It avoids emitting + ;; a property write on every render while keeping state protocol-local. + (wm-state :withdrawn)) + +(defun backend-client-icccm-info (backend client-id) + "Return cached ICCCM facts for CLIENT-ID, or NIL when it is not managed." + (gethash client-id (x11-backend-icccm-clients backend))) + +(defun %protocol-member-p (protocol protocols) + (not (null (member protocol protocols :test #'string-equal)))) + +(defun %refreshed-wm-state (previous-info) + "Keep renderer-owned WM_STATE across a metadata-only property refresh." + (if previous-info + (icccm-client-info-wm-state previous-info) + :withdrawn)) + +(defun icccm-wm-state-data (state) + "Return the two-cardinal WM_STATE payload for STATE. + +The second field is the ICCCM icon-window slot, which Lime intentionally does +not use. :WITHDRAWN is useful for inspection, but withdrawing a real client +removes the property rather than storing this zero value." + (list (ecase state + (:withdrawn 0) + (:normal 1) + (:iconic 3)) + 0)) + +(defun icccm-set-client-state (backend client-id window state &key force-p) + "Publish STATE for CLIENT-ID when Lime's cached value changes. + +Lime uses :NORMAL for a client rendered in a leased Presentation and :ICONIC +when a View hides that client. This does not create an independent minimized +window concept: the Activity/View lease still determines whether it appears. +FORCE-P is reserved for the ownership handoff in STOP-BACKEND, where Lime must +leave a normal visible state even if its local cache is stale." + (unless (member state '(:normal :iconic)) + (error "WM_STATE ~S cannot be published; use ICCCM-WITHDRAW-CLIENT for withdrawal." + state)) + (let ((info (backend-client-icccm-info backend client-id))) + (unless (and (not force-p) + info + (eq (icccm-client-info-wm-state info) state)) + (xlib:change-property window :WM_STATE (icccm-wm-state-data state) + :WM_STATE 32) + (when info + (setf (icccm-client-info-wm-state info) state)))) + state) + +(defun icccm-withdraw-client (backend client-id window) + "Remove CLIENT-ID's WM_STATE property after an application withdrawal." + (xlib:delete-property window :WM_STATE) + (let ((info (backend-client-icccm-info backend client-id))) + (when info + (setf (icccm-client-info-wm-state info) :withdrawn))) + :withdrawn) + +(defun %accepts-input-p (window) + "Apply ICCCM's default: a missing InputHint means the client accepts input." + (let ((hints (xlib:wm-hints window))) + (not (and hints + (eq (xlib:wm-hints-input hints) :off))))) + +(defun %transient-client-id (backend window) + (let ((parent (xlib:transient-for window))) + (and parent (%backend-client-id backend parent)))) + +(defun %nonempty-title (text) + (and (stringp text) (plusp (length text)) text)) + +(defun %read-title-property (window property type encoding) + (multiple-value-bind (data actual-type format) + (xlib:get-property window property :type type :end 4096 :result-type 'vector) + (declare (ignore actual-type)) + (and (= (or format 0) 8) data + (%nonempty-title + (babel:octets-to-string (coerce data '(vector (unsigned-byte 8))) + :encoding encoding :errorp nil))))) + +(defun %read-client-title (window) + "Prefer EWMH's UTF-8 title, falling back to legacy ICCCM WM_NAME. + +Malformed or wrongly typed modern properties must not break window adoption. +Bound the property read; titles are display metadata, not arbitrary payloads." + (or (%read-title-property window :_NET_WM_NAME :UTF8_STRING :utf-8) + (%read-title-property window :WM_NAME :STRING :iso-8859-1))) + +(defun icccm-refresh-client-info (backend client-id window) + "Read ICCCM properties for WINDOW and replace CLIENT-ID's backend cache." + (multiple-value-bind (resource-name resource-class) + (xlib:get-wm-class window) + (let* ((previous-info (backend-client-icccm-info backend client-id)) + (protocols (xlib:wm-protocols window)) + (info (make-icccm-client-info + :client-id client-id + :window-id (xlib:window-id window) + :title (%read-client-title window) + :resource-name resource-name + :resource-class resource-class + :protocols (copy-list protocols) + :accepts-input-p (%accepts-input-p window) + :delete-window-p (%protocol-member-p "WM_DELETE_WINDOW" + protocols) + :take-focus-p (%protocol-member-p "WM_TAKE_FOCUS" protocols) + :transient-for-client-id (%transient-client-id backend window) + :normal-hints (xlib:wm-normal-hints window) + ;; A property refresh must not forget whether Lime already + ;; hid this client. Otherwise an unrelated title/hint change + ;; could queue a redundant unmap and leave a false pending + ;; token for a later genuine withdrawal. + :wm-state (%refreshed-wm-state previous-info)))) + (setf (gethash client-id (x11-backend-icccm-clients backend)) info) + info))) + +(defun icccm-adopt-client (backend client-id window) + "Begin tracking client properties and cache its current ICCCM declaration." + ;; Event masks are selected per X client, so this does not disturb the + ;; client's own selections. Property changes let a future UI see title/class + ;; updates and keep focus/close capabilities current. + (setf (xlib:window-event-mask window) + (logior (xlib:window-event-mask window) + (xlib:make-event-mask :property-change :focus-change))) + (icccm-refresh-client-info backend client-id window)) + +(defun icccm-forget-client (backend client-id) + "Remove backend-only ICCCM state after a destroy or withdrawal." + (remhash client-id (x11-backend-icccm-clients backend)) + client-id) + +(defun icccm-handle-client-message (backend window type format data) + "Recognize ICCCM messages Lime deliberately handles. + +Lime has no independent minimize bucket: a View is the user-facing way to +hide a window while retaining it in its task. Therefore a WM_CHANGE_STATE +iconify request is recognized and safely declined rather than quietly turning +it into a destructive withdrawal. Returning true keeps EWMH dispatch from +misinterpreting the ICCCM atom." + (declare (ignore backend window format data)) + (eq type :WM_CHANGE_STATE)) + +(defun icccm-handle-property-notify (backend client-id window atom) + "Refresh client metadata, including the EWMH override of ICCCM's title." + (when (member atom '(:_NET_WM_NAME :WM_NAME :WM_CLASS :WM_PROTOCOLS :WM_HINTS + :WM_NORMAL_HINTS :WM_TRANSIENT_FOR)) + (icccm-refresh-client-info backend client-id window)) + nil) + +(defun %send-wm-protocol (window protocol) + "Send one WM_PROTOCOLS client message with CurrentTime." + (let ((display (xlib:window-display window))) + (xlib:send-event window :client-message nil + :window window + :format 32 + :type :WM_PROTOCOLS + :data (list (xlib:intern-atom display protocol) 0 0 0 0)))) + +(defun icccm-focus-client (backend client-id window) + "Honor InputHint and WM_TAKE_FOCUS for a rendered focus target. + +When a client cannot accept either kind of focus, input deliberately falls back +to the root rather than leaving it on an unrelated hidden client." + (let ((info (or (backend-client-icccm-info backend client-id) + (icccm-refresh-client-info backend client-id window))) + (delivered-p nil)) + (when (icccm-client-info-accepts-input-p info) + (xlib:set-input-focus (x11-backend-display backend) window :pointer-root) + (setf delivered-p t)) + (when (icccm-client-info-take-focus-p info) + (%send-wm-protocol window :WM_TAKE_FOCUS) + (setf delivered-p t)) + (unless delivered-p + (xlib:set-input-focus (x11-backend-display backend) + (x11-backend-root backend) + :pointer-root)) + info)) + +(defun icccm-request-close (backend client-id window) + "Request CLIENT-ID close gracefully, falling back to XKillClient if needed. + +The client stays in Lime's model until its real DestroyNotify arrives; this +function only asks the external client to terminate." + (let ((info (or (backend-client-icccm-info backend client-id) + (icccm-refresh-client-info backend client-id window)))) + (if (icccm-client-info-delete-window-p info) + (progn + (%send-wm-protocol window :WM_DELETE_WINDOW) + :wm-delete-window) + (progn + (xlib:kill-client (x11-backend-display backend) (xlib:window-id window)) + :kill-client)))) + +(defun icccm-send-configure-notify (window) + "Tell a tiled client the geometry actually assigned by the window manager." + (xlib:send-event window :configure-notify nil + :event-window window + :window window + :above-sibling nil + :x (xlib:drawable-x window) + :y (xlib:drawable-y window) + :width (xlib:drawable-width window) + :height (xlib:drawable-height window) + :border-width (xlib:drawable-border-width window) + :override-redirect-p nil)) diff --git a/src/x11/input.lisp b/src/x11/input.lisp new file mode 100644 index 0000000..f7fa0d5 --- /dev/null +++ b/src/x11/input.lisp @@ -0,0 +1,186 @@ +(in-package #:lime.x11) + +;;;; Opt-in keyboard input +;;; +;;; This layer translates a passive X11 key grab into a handler supplied by the +;;; user. Handlers receive the X11-BACKEND and normally call a command from +;;; x11/commands.lisp. It intentionally knows no View ids, Activity names, +;;; menus, or collision policy itself. + +(defstruct keybinding + "One character/keysym binding owned by an X11 backend." + key + modifiers + state + keycodes + handler + description) + +(defun %input-keysym (display key) + (typecase key + (character + (or (first (xlib:character->keysyms key display)) + (error 'invalid-transition + :description (format nil "No X11 keysym is known for ~S." key)))) + ((integer 0 *) key) + (otherwise + (error 'invalid-transition + :description "A keybinding key must be a character or X11 keysym integer.")))) + +(defun %input-keycodes (display key) + (let ((keysym (%input-keysym display key))) + (or (remove nil (multiple-value-list (xlib:keysym->keycodes display keysym))) + (error 'invalid-transition + :description (format nil "No X11 keycode is available for ~S." key))))) + +(defun %input-state (modifiers) + (typecase modifiers + (integer modifiers) + (list (apply #'xlib:make-state-mask modifiers)) + (otherwise + (error 'invalid-transition + :description "Keybinding modifiers must be an integer mask or modifier list.")))) + +(defparameter +input-ignored-state-mask+ + ;; X11 commonly assigns Caps Lock to :LOCK and Num Lock to :MOD-2. Neither + ;; should make a window-manager keybinding mysteriously stop matching. The + ;; physical mapping is discovered from the server for more exotic setups in + ;; a later input pass; these two portable CLX names cover Lime's current + ;; Xorg sessions and the conventional X11 assignment. + (xlib:make-state-mask :lock :mod-2)) + +(defun %input-state-variants (state) + "Return STATE's lock-insensitive passive-grab variants. + +Passive X11 grabs are exact, whereas a key press with Caps Lock or Num Lock +active should still invoke the same command. Register every combination and +store all of them in the dispatch table; callers continue to expose only the +user's original modifier list in keybinding descriptions." + (remove-duplicates + (loop for ignored-state in + (list 0 + (xlib:make-state-mask :lock) + (xlib:make-state-mask :mod-2) + +input-ignored-state-mask+) + collect (logior state ignored-state)))) + +(defun %input-binding-key (keycode state) + (cons keycode state)) + +(defun %ungrab-binding (backend binding) + (let ((root (x11-backend-root backend))) + (dolist (keycode (keybinding-keycodes binding)) + (dolist (state (%input-state-variants (keybinding-state binding))) + (xlib:ungrab-key root keycode :modifiers state))))) + +(defun %remove-binding (backend binding) + "Ungrab BINDING and erase every table entry that still points to it." + (%ungrab-binding backend binding) + (let ((table (x11-backend-keybindings backend)) + (keys '())) + (maphash (lambda (table-key candidate) + (when (eq candidate binding) + (push table-key keys))) + table) + (dolist (table-key keys) + (remhash table-key table)))) + +(defun bind-key (backend key modifiers handler &key description) + "Passively grab KEY with MODIFIERS and run HANDLER when it is pressed. + +KEY is a character or an X11 keysym integer. MODIFIERS is an integer mask or +a CLX modifier list such as '(:MOD-4). HANDLER receives BACKEND as its sole +argument and should invoke a command-layer operation. Rebinding the same +physical key/modifier pair replaces its previous handler. The passive grab +briefly queues subsequent keyboard events until dispatch can hand them to a +new palette grab or release them normally, even if the trigger was released." + (unless (functionp handler) + (error 'invalid-transition :description "A keybinding handler must be a function.")) + (let* ((display (x11-backend-display backend)) + (root (x11-backend-root backend)) + (state (%input-state modifiers)) + (keycodes (%input-keycodes display key)) + (binding (make-keybinding :key key + :modifiers modifiers + :state state + :keycodes keycodes + :handler handler + :description description)) + (table (x11-backend-keybindings backend))) + (dolist (keycode keycodes) + (let* ((table-key (%input-binding-key keycode state)) + (old (gethash table-key table))) + (when old + (%remove-binding backend old)) + (dolist (grab-state (%input-state-variants state)) + (xlib:grab-key root keycode :modifiers grab-state :sync-keyboard-p t) + (setf (gethash (%input-binding-key keycode grab-state) table) + binding)))) + (xlib:display-force-output display) + binding)) + +(defun unbind-key (backend key modifiers) + "Release KEY/MODIFIERS and return whether at least one binding was removed." + (let* ((display (x11-backend-display backend)) + (state (%input-state modifiers)) + (keycodes (%input-keycodes display key)) + (table (x11-backend-keybindings backend)) + (removed-p nil)) + (dolist (keycode keycodes) + (let* ((table-key (%input-binding-key keycode state)) + (binding (gethash table-key table))) + (when binding + (%remove-binding backend binding) + (setf removed-p t)))) + (xlib:display-force-output display) + removed-p)) + +(defun clear-keybindings (backend) + "Remove every passive key grab registered through BIND-KEY." + (let ((seen (make-hash-table :test #'eq))) + (maphash (lambda (table-key binding) + (declare (ignore table-key)) + (unless (gethash binding seen) + (%ungrab-binding backend binding) + (setf (gethash binding seen) t))) + (x11-backend-keybindings backend)) + (clrhash (x11-backend-keybindings backend)) + (xlib:display-force-output (x11-backend-display backend))) + backend) + +(defun list-keybindings (backend) + "Return unique KEYBINDING objects currently installed on BACKEND." + (let ((seen (make-hash-table :test #'eq)) + (bindings '())) + (maphash (lambda (table-key binding) + (declare (ignore table-key)) + (unless (gethash binding seen) + (push binding bindings) + (setf (gethash binding seen) t))) + (x11-backend-keybindings backend)) + (nreverse bindings))) + +(defun backend-last-command-error (backend) + "Return the most recent condition raised by an input handler, if any." + (x11-backend-last-command-error backend)) + +(defun %handle-key-press (backend keycode state) + "Dispatch a grabbed KeyPress without allowing a handler error to kill Lime." + (unwind-protect + (let ((binding (gethash (%input-binding-key keycode state) + (x11-backend-keybindings backend)))) + (when binding + (handler-case + (progn + (setf (x11-backend-last-command-error backend) nil) + (funcall (keybinding-handler binding) backend) + t) + (error (condition) + (setf (x11-backend-last-command-error backend) condition) + nil)))) + ;; A successful palette grab already thaws input into its own queue. + ;; Ordinary commands, failures, and removed bindings must thaw it too. + (let ((display (x11-backend-display backend))) + (when display + (xlib:allow-events display :async-keyboard) + (xlib:display-force-output display))))) diff --git a/src/x11/launcher.lisp b/src/x11/launcher.lisp new file mode 100644 index 0000000..145f7bf --- /dev/null +++ b/src/x11/launcher.lisp @@ -0,0 +1,144 @@ +(in-package #:lime.x11) + +;;;; Process launching boundary +;;; +;;; Activities, Views, and leases do not know how a client was created. This +;;; tiny adapter utility owns process creation so the palette, default bindings, +;;; and user configuration can all launch a normal X client without growing a +;;; second, dmenu-specific UI or leaking shell mechanics into the core model. + +(defun %nonblank-launch-command (command) + "Trim COMMAND or signal the same useful transition condition as UI commands." + (unless (stringp command) + (error 'invalid-transition :description "A launch command must be a string.")) + (let ((trimmed (string-trim '(#\Space #\Tab #\Newline #\Return) command))) + (when (zerop (length trimmed)) + (error 'invalid-transition :description "A launch command cannot be blank.")) + trimmed)) + +(defun %normalize-program-names (names) + "Return distinct nonblank executable names in stable alphabetical order." + (let ((seen (make-hash-table :test #'equal))) + (sort (loop for name in names + when (and (stringp name) (plusp (length name)) (not (gethash name seen))) + collect name and do (setf (gethash name seen) t)) + #'string-lessp))) + +(defun %scan-path-program-names () + "Discover executable file names on PATH without making a shell typed by the user. + +The small POSIX probe is deliberately independent of dmenu: Lime needs the +same ordinary executable catalog even when dmenu is not installed. Its output +becomes inert cached data, never code. Actual launching uses an argument vector in +BACKEND-LAUNCH-PROGRAM, never interpolated shell text." + (handler-case + (%normalize-program-names + (uiop:split-string + (uiop:run-program + (list "/bin/sh" "-c" + "IFS=: +for directory in $PATH; do + for program in \"$directory\"/*; do + [ -f \"$program\" ] && [ -x \"$program\" ] && printf '%s\\n' \"${program##*/}\" + done +done") + :output :string :ignore-error-status t) + :separator '(#\Newline #\Return))) + (error () + ;; A missing/broken PATH should leave the picker empty and explain the + ;; situation through its ordinary "no matching program" state, not take + ;; down the X event loop. + '()))) + +(defvar *path-program-cache* nil + "Process-local executable catalog; never persisted into the user's session.") + +(defun %path-program-signature () + "Cheap invalidation for PATH edits and installed/removed/renamed programs." + (let ((path (or (uiop:getenv "PATH") ""))) + (list path (namestring (uiop:getcwd)) + (loop for directory in (uiop:split-string path :separator '(#\:)) + collect (ignore-errors + (file-write-date + (uiop:ensure-directory-pathname + (if (zerop (length directory)) "." directory)))))))) + +(defun %path-program-names (&key refresh-p) + "Reuse executable names while PATH and its directories are unchanged. + +Directory dates detect ordinary installs/removals. Also refresh after five +minutes on the next open to catch permission-only edits and coarse timestamps. +REFRESH-P forces immediate discovery for callers editing executable scripts." + (let ((signature (%path-program-signature)) + (now (get-internal-real-time))) + (unless (and (not refresh-p) *path-program-cache* + (equal signature (getf *path-program-cache* :signature)) + (< (- now (getf *path-program-cache* :time)) + (* 300 internal-time-units-per-second))) + (setf *path-program-cache* + (list :signature signature :time now :programs (%scan-path-program-names)))) + ;; Sessions/callers may rearrange their list, but not the cached catalog. + (copy-list (getf *path-program-cache* :programs)))) + +(declaim (ftype function %cursor-session-launch-argv)) +(defun backend-launch-program (backend argv) + "Launch an argument-vector ARGV in Lime's inherited X session environment. + +ARGV is deliberately an argument list, not shell text. The new top-level +window will arrive through the normal MapRequest path and join the selected +Head's live Presentation like any external client. The configured cursor theme +is passed to this child without changing the process-wide environment. No +Activity/View policy is hidden in the launcher itself." + (unless (and (consp argv) + (every #'stringp argv) + (not (zerop (length (first argv))))) + (error 'invalid-transition + :description "A program launch needs a non-empty list of string arguments.")) + (uiop:launch-program (%cursor-session-launch-argv backend argv) + :output :interactive :error-output :interactive)) + +(defun backend-launch-shell-command (backend command) + "Run COMMAND through /bin/sh -c in Lime's inherited session environment. + +This is the dmenu_run-like escape hatch for a user who explicitly typed a +command into Lime's palette. Configured commands should normally prefer +BACKEND-LAUNCH-PROGRAM with a fixed argument vector." + (backend-launch-program backend + (list "/bin/sh" "-c" (%nonblank-launch-command command)))) + +(defun backend-launch-terminal (backend) + "Launch the user's current dwm terminal default, st." + (backend-launch-program backend '("st"))) + +(defun %lime-browser-profile-directory () + "Return Lime's persistent, separate Waterfox profile directory. + +Two concurrent Waterfox processes cannot safely use the same profile. A Lime +test session commonly runs beside an existing desktop session, so use a small +dedicated profile under the XDG state home instead of showing Waterfox's +profile-lock dialog or forwarding a window to another DISPLAY." + (let* ((state-home + (uiop:ensure-directory-pathname + (or (uiop:getenv "XDG_STATE_HOME") + (merge-pathnames #P".local/state/" (user-homedir-pathname))))) + (profile-directory + (merge-pathnames #P"lime/waterfox-profile/" state-home))) + ;; ENSURE-DIRECTORIES-EXIST takes a prospective file pathname. The + ;; sentinel is never created; it simply ensures the full profile path is + ;; available before Waterfox initializes its own profile files. + (ensure-directories-exist (merge-pathnames #P".profile-directory-ready" + profile-directory)) + (namestring profile-directory))) + +(defun backend-launch-browser (backend &key test-profile-p) + "Launch Waterfox normally, letting it select the user's usual profile. + +TEST-PROFILE-P explicitly opts into an isolated profile for a concurrent +nested-X session. Never silently substitute that profile on a real desktop: +doing so makes the user's tabs, extensions, and theme appear to be missing." + (backend-launch-program + backend + (if test-profile-p + (list "waterfox" "--new-instance" "--profile" + (%lime-browser-profile-directory)) + '("waterfox")))) diff --git a/src/x11/lifecycle.lisp b/src/x11/lifecycle.lisp new file mode 100644 index 0000000..a3b6474 --- /dev/null +++ b/src/x11/lifecycle.lisp @@ -0,0 +1,178 @@ +(in-package #:lime.x11) + +;;;; Client lifecycle normalization +;;; +;;; X11 events answer "what happened to this client?" They do not choose an +;;; Activity, View, layout, or collision policy. This module translates that +;;; narrow lifecycle information into model commands, then asks rendering to +;;; reconcile the resulting state. + +;; Configuration is deliberately loaded after lifecycle so a configuration +;; file can depend on the complete adapter command surface. These functions +;; are defined there but are only called after the complete system loads. +(declaim (ftype (function (t) t) configured-new-client-focus-p) + (ftype (function (t t) t) + configured-new-tiled-client-position + configured-close-focus-direction)) +(declaim (ftype function %session-note-client %session-forget-client)) + +(defun manage-window (backend window) + "Adopt a MapRequest into a task draft or map an external EWMH surface. + +Dock and desktop windows are real EWMH clients but not user task windows, so +they retain application geometry outside Activities, Views, and leases." + (unless (or (= (xlib:window-id window) (xlib:window-id (x11-backend-root backend))) + (eq (xlib:window-override-redirect window) :on)) + (let ((window-types (%ewmh-window-types-for-window backend window))) + (if (%ewmh-external-window-types-p window-types) + (ewmh-adopt-external-window backend window window-types) + (let* ((world (x11-backend-world backend)) + (client-id (or (%backend-client-id backend window) + (%client-id-for-window window)))) + (%register-window backend client-id window) + (%session-note-client backend client-id window) + (icccm-adopt-client backend client-id window) + (ewmh-adopt-client backend client-id window) + (let ((decision (new-client-placement-decision backend client-id window))) + (handler-case + (find-client world client-id) + (unknown-entity () + ;; A normal window follows the selected Presentation. A managed + ;; transient deliberately follows its parent's Presentation and + ;; Activity, even when another Head is currently selected. + (create-client world client-id + (x11-placement-decision-activity-id decision) + :name client-id))) + (pointer-adopt-client backend window) + (let* ((presentation + (find-presentation + world (x11-placement-decision-presentation-id decision))) + (layout-mode (presentation-layout-mode presentation)) + (focus-p (or (x11-placement-decision-focus-p decision) + (configured-new-client-focus-p backend)))) + (show-client-on-presentation + world client-id (x11-placement-decision-presentation-id decision) + :kind (x11-placement-decision-kind decision) + :data (x11-placement-decision-data decision) + :tiled-insertion-position + (if (eq (x11-placement-decision-kind decision) :tile) + (configured-new-tiled-client-position backend layout-mode) + :back) + :focus-p focus-p) + (cond + ;; Some games publish their desired state before MapRequest instead + ;; of sending a later client message. Honor that initial request + ;; through the same command used by EWMH events. + ((ewmh-window-requests-fullscreen-p backend window) + (backend-set-client-fullscreen backend client-id t)) + (focus-p + ;; Both regular newly managed clients and transient/dialog + ;; surfaces use the same focus policy; the latter simply + ;; force it on even in a no-focus-on-new-client config. + (backend-focus-client backend client-id + :head-id (x11-placement-decision-head-id decision))) + (t (apply-active-presentation backend)))) + client-id)))))) + +(defun %handle-configure-request + (backend window x y width height border-width value-mask + &optional parent above-sibling) + ;; Lime retains geometry authority for both tiles and floats. The renderer + ;; now applies cached WM_NORMAL_HINTS before restoring that geometry, then + ;; a synthetic ConfigureNotify tells the client exactly what it received. + ;; EWMH docks/desktops are intentionally the sole exception: those are not + ;; Activity clients and retain their application-owned geometry. + ;; PARENT and ABOVE-SIBLING complete the ConfigureRequest contract. Lime + ;; has no stacking policy for normal client requests yet, so they are + ;; deliberately retained by the adapter but not acted upon. + (declare (ignore parent above-sibling)) + (if (ewmh-handle-external-configure-request + backend window x y width height border-width value-mask) + (xlib:display-force-output (x11-backend-display backend)) + (when (%registered-window-p backend window) + (apply-active-presentation backend) + (icccm-send-configure-notify window) + (xlib:display-force-output (x11-backend-display backend)))) + nil) + +(defun %retire-managed-client (backend client-id &key window-id) + "Remove a gone CLIENT-ID from backend caches and every core container." + (when client-id + (%session-forget-client backend client-id) + (remhash client-id (x11-backend-original-border-widths backend)) + (pointer-forget-client backend client-id) + (icccm-forget-client backend client-id) + (ewmh-forget-client backend client-id :window-id window-id) + ;; Adoption can lose a window during its initial property queries, before + ;; it has a core client. Adapter cleanup must still be complete/idempotent. + (when (handler-case (find-client (x11-backend-world backend) client-id) + (unknown-entity () nil)) + (retire-client + (x11-backend-world backend) client-id + :focus-direction + (lambda (container) + (configured-close-focus-direction + backend + (typecase container + (presentation (presentation-layout-mode container)) + (view (view-layout-mode container)))))))) + client-id) + +(defun %handle-destroy-notify (backend window) + "Retire a permanently destroyed X11 client before reconciling survivors." + (let ((client-id (%forget-window backend window))) + (when client-id + (%forget-pending-unmaps backend window) + (%retire-managed-client backend client-id :window-id (xlib:window-id window)) + (apply-active-presentation backend)) + (unless client-id + (ewmh-forget-external-window backend window))) + nil) + +(defun %handle-unmap-notify (backend event-window window configure-p) + "Distinguish Lime's View hides from an application's ICCCM withdrawal. + +The root receives both kinds because it selected :SUBSTRUCTURE-NOTIFY. A +renderer token identifies our own unmap. Parent-resize unmaps are not client +withdrawals, and an unknown window is already outside Lime's ownership." + (let ((client-id (%backend-client-id backend window))) + (cond + ((null client-id) + (ewmh-forget-external-window backend window) + nil) + ((%consume-pending-unmap-p backend window) nil) + ((or configure-p + ;; The root is the ordinary event recipient. Keep this guard so + ;; a future per-window event subscription cannot accidentally turn + ;; a hierarchy detail into a task-client retirement. + ;; CLX may recreate a wrapper after QueryTree/InputFocus lookups; + ;; protocol identity is the XID, not Lisp object identity. + (/= (xlib:window-id event-window) + (xlib:window-id (x11-backend-root backend)))) + nil) + (t + ;; ICCCM withdrawal means the application removed itself. It is not a + ;; hidden member of a View, so retire it just like DestroyNotify. + (icccm-withdraw-client backend client-id window) + (%restore-client-border backend client-id window) + (%forget-window backend window) + (%retire-managed-client backend client-id :window-id (xlib:window-id window)) + (apply-active-presentation backend)))) + nil) + +(defun %handle-property-notify (backend window atom) + "Refresh metadata; repaint titles without reapplying client geometry." + (let ((client-id (%backend-client-id backend window))) + (when client-id + (icccm-handle-property-notify backend client-id window atom) + (ewmh-handle-property-notify backend client-id window atom) + (when (member atom '(:WM_HINTS :_NET_WM_STATE)) + (%attention-refresh-client backend client-id window) + (%attention-acknowledge-client backend client-id)) + ;; A property update stays entirely adapter-local, but changed hints + ;; should take effect before the next user action or ConfigureRequest. + (cond + ((eq atom :WM_NORMAL_HINTS) (apply-active-presentation backend)) + ((member atom '(:_NET_WM_NAME :WM_NAME :WM_CLASS :WM_HINTS :_NET_WM_STATE)) + (render-head-bars backend))))) + nil) diff --git a/src/x11/navigation.lisp b/src/x11/navigation.lisp new file mode 100644 index 0000000..31260b7 --- /dev/null +++ b/src/x11/navigation.lisp @@ -0,0 +1,234 @@ +(in-package #:lime.x11) + +;;;; Ordered Activity shortcuts, stable View slots, and Head-local history. +;;;; These are adapter +;;;; navigation metadata, never Activity/View identities or layout state. + +(defstruct navigation-state + (activities nil) (views nil) (resume nil) + observed-world observed-revision (generation 0)) + +;; A separately owned runtime lets navigation evolve without redefining the +;; live backend's structure. STOP-BACKEND releases it on every implementation. +(defvar *backend-navigation-states* + (make-hash-table :test #'eq #+sbcl :weakness #+sbcl :key)) + +(declaim (ftype function %forget-activity-navigation-state %portable-activity-presentation)) + +(defun %forget-navigation-state (backend) + (remhash backend *backend-navigation-states*) + (%forget-activity-navigation-state backend)) + +(defun %navigation-slots (existing ids) + "Keep surviving assignments; fill holes for new ids without shifting peers." + (let ((result (remove-if-not (lambda (row) (member (first row) ids :test #'equal)) existing))) + (dolist (id ids) + (unless (assoc id result :test #'equal) + (push (list id (loop for slot from 1 + unless (find slot result :key #'second) return slot)) result))) + (sort (copy-list result) #'< :key #'second))) + +(defun %navigation-activity-slots (existing ids) + "Keep the surviving bar order, close gaps, and append previously unseen ids. + +Always allocate fresh rows: synchronization must not mutate persisted input or +an earlier navigation snapshot. View slots deliberately use the stable policy." + (let* ((survivors (sort (copy-list (remove-if-not (lambda (row) (member (first row) ids :test #'equal)) existing)) + #'< :key #'second)) + (ordered-ids (append (mapcar #'first survivors) + (remove-if (lambda (id) (assoc id survivors :test #'equal)) ids)))) + (loop for id in ordered-ids for slot from 1 collect (list id slot)))) + +(defun %navigation-state (backend) + "Synchronize tiny navigation indexes, at most once per model revision." + (let* ((state (or (gethash backend *backend-navigation-states*) + (setf (gethash backend *backend-navigation-states*) (make-navigation-state)))) + (world (x11-backend-world backend))) + (unless (and (eq world (navigation-state-observed-world state)) + (eql (world-revision world) (navigation-state-observed-revision state))) + (let* ((activities + (sort (list-activities world) #'string< + :key (lambda (a) + ;; A predictable migration for desks with no slots. + (if (equal "scratch" (activity-id a)) "" + (format nil "~A ~S" (string-downcase (activity-name a)) (activity-id a)))))) + (activity-slots (%navigation-activity-slots (navigation-state-activities state) + (mapcar #'activity-id activities))) + (view-slots + (loop for a in activities append + (%navigation-slots + (remove-if-not (lambda (row) (member (first row) (activity-view-ids a) :test #'equal)) + (navigation-state-views state)) + (activity-view-ids a)))) + (resume + (remove-if-not + (lambda (row) + (let ((p (gethash (third row) (lime.core::world-presentations world)))) + (and p (equal (first row) (presentation-head-id p)) + (equal (second row) (presentation-activity-id p))))) + (navigation-state-resume state)))) + ;; Record all active Heads, not just the selected one. Previously + ;; rendered presentations remain in history when another takes over. + (dolist (head-id (backend-head-ids backend)) + (let ((p (current-presentation world head-id))) + (when p + (setf resume + (cons (list head-id (presentation-activity-id p) (presentation-id p)) + (remove-if (lambda (row) (and (equal head-id (first row)) + (equal (presentation-activity-id p) (second row)))) + resume)))))) + (unless (and (equal activity-slots (navigation-state-activities state)) + (equal view-slots (navigation-state-views state)) + (equal resume (navigation-state-resume state))) + (incf (navigation-state-generation state))) + (setf (navigation-state-activities state) activity-slots + (navigation-state-views state) view-slots + (navigation-state-resume state) resume + (navigation-state-observed-world state) world + (navigation-state-observed-revision state) (world-revision world)))) + state)) + +(defun backend-activity-slot (backend activity-id) + (second (assoc activity-id (navigation-state-activities (%navigation-state backend)) :test #'equal))) + +(defun backend-view-slot (backend view-id) + (second (assoc view-id (navigation-state-views (%navigation-state backend)) :test #'equal))) + +(defun %assign-navigation-slot (rows id slot) + (unless (typep slot '(integer 1 *)) + (error 'invalid-transition :description "A navigation slot must be a positive integer.")) + (let* ((result (copy-tree rows)) (target (assoc id result :test #'equal)) + (occupant (find slot result :key #'second))) + (unless target (error 'invalid-transition :description "No navigation target with that id.")) + (when occupant (setf (second occupant) (second target))) + (setf (second target) slot) + (sort result #'< :key #'second))) + +(defun backend-set-activity-slot (backend activity-id slot) + "Swap with bar position SLOT (1 through the Activity count). No window moves." + (find-activity (x11-backend-world backend) activity-id) + (let ((state (%navigation-state backend))) + (unless (and (typep slot '(integer 1 *)) + (<= slot (length (navigation-state-activities state)))) + (error 'invalid-transition :description "An Activity position must be between 1 and the Activity count.")) + (setf (navigation-state-activities state) + (%assign-navigation-slot (navigation-state-activities state) activity-id slot)) + (incf (navigation-state-generation state))) + (when (x11-backend-display backend) (render-head-bars backend)) + slot) + +(defun backend-set-view-slot (backend view-id slot) + "Assign a slot local to the View's Activity; swap only within that Activity." + (let* ((world (x11-backend-world backend)) (view (find-view world view-id)) + (ids (activity-view-ids (find-activity world (view-activity-id view)))) + (state (%navigation-state backend))) + (setf (navigation-state-views state) + (append (%assign-navigation-slot + (remove-if-not (lambda (row) (member (first row) ids :test #'equal)) + (navigation-state-views state)) view-id slot) + (remove-if (lambda (row) (member (first row) ids :test #'equal)) + (navigation-state-views state)))) + (incf (navigation-state-generation state))) + (when (x11-backend-display backend) (render-head-bars backend)) + slot) + +(defun backend-navigation-slots (backend) + "Return independent lists of (id slot), with Views numbered per Activity." + (let ((state (%navigation-state backend))) + (copy-tree (list :activities (navigation-state-activities state) + :views (navigation-state-views state))))) + +(defun %navigation-snapshot (backend) + (let ((state (%navigation-state backend))) + (lime.persistence:copy-data + (list :activities (navigation-state-activities state) + :views (navigation-state-views state) :resume (navigation-state-resume state))))) + +(defun %navigation-read-data (data world) + "Validate persisted navigation independently before replacing any live state." + (lime.persistence:check-data data) + (lime.persistence:check-record data '(:activities :views :resume)) + (dolist (key '(:activities :views)) + (let ((ids nil) (slots nil)) + (dolist (row (getf data key)) + (unless (and (listp row) (= 2 (length row)) (typep (second row) '(integer 1 *))) + (error "Malformed navigation slot.")) + (let* ((id (first row)) + (scope (if (eq key :activities) + (progn (find-activity world id) :activities) + (view-activity-id (find-view world id)))) + (slot (list scope (second row)))) + (when (or (member id ids :test #'equal) (member slot slots :test #'equal)) + (error "Duplicate navigation id or slot.")) + (push id ids) (push slot slots))))) + (let ((seen nil)) + (dolist (row (getf data :resume)) + (unless (and (listp row) (= 3 (length row))) (error "Malformed navigation resume entry.")) + (let ((p (find-presentation world (third row))) (key (subseq row 0 2))) + (unless (and (equal (first row) (presentation-head-id p)) + (equal (second row) (presentation-activity-id p)) + (not (member key seen :test #'equal))) + (error "Invalid navigation resume target.")) + (push key seen)))) + ;; Accept older sparse assignments, but preserve only their ordering. Do + ;; this after validation so compaction cannot mask duplicate/corrupt slots. + (make-navigation-state :activities (%navigation-activity-slots + (getf data :activities) + (mapcar #'first (getf data :activities))) + :views (copy-tree (getf data :views)) :resume (copy-tree (getf data :resume)))) + +(defun %navigation-resume-target (backend activity-id head-id) + ;; History is retained for old-session migration, not as another source of + ;; working state. There is exactly one current arrangement for this pair. + (let ((p (activity-draft-for-head (x11-backend-world backend) activity-id head-id))) + (and p (presentation-id p)))) + +(defun backend-preflight-activity-switch (backend activity-id &key (head-id (x11-backend-focused-head-id backend))) + "Inspect resuming the last live arrangement, not reloading its checkpoint." + (%head-for-id backend head-id) + (find-activity (x11-backend-world backend) activity-id) + (let ((portable (%portable-activity-presentation backend activity-id))) + (if portable + (preflight-presentation-bring (x11-backend-world backend) head-id (presentation-id portable)) + (preflight-activity-draft (x11-backend-world backend) head-id activity-id + :default-layout (configured-default-layout backend))))) + +(defun backend-switch-to-activity (backend activity-id &key (head-id (x11-backend-focused-head-id backend)) (policy :strict)) + "Bring a portable Activity here, or resume this Head's extended portion." + (unless (member policy '(:strict :partial :take)) + (error 'invalid-transition :description "Activity policy must be :STRICT, :PARTIAL, or :TAKE.")) + (let* ((world (x11-backend-world backend)) (current (current-presentation world head-id)) + (portable (%portable-activity-presentation backend activity-id)) + (target (%navigation-resume-target backend activity-id head-id))) + (%head-for-id backend head-id) + (find-activity world activity-id) + (cond ((and portable (eq portable current)) current) + (portable (%apply-command-result backend + (bring-presentation-to-head world (presentation-id portable) head-id))) + ((and current (equal activity-id (presentation-activity-id current))) current) + (target (%apply-command-result backend (%resume-presentation-with-policy world head-id target policy))) + (t (%apply-command-result backend + (open-activity-draft world head-id activity-id :policy policy + :default-layout (configured-default-layout backend))))))) + +(declaim (ftype function %ui-request-activity-activation %ui-request-view-activation %open-ui-session)) + +(defun %show-navigation-result (backend result) + ;; Successful requests never open a menu. Only conflicts need interaction. + (unless (eq :close (ui-result-kind result)) + (%open-ui-session backend (make-ui-session (ui-result-candidates result) + :status (ui-result-message result)))) + result) + +(defun backend-select-activity-slot (backend slot) + "Select numbered Activity on the focused Head; an empty slot is a no-op." + (let ((id (first (find slot (navigation-state-activities (%navigation-state backend)) :key #'second)))) + (when id (%show-navigation-result backend (%ui-request-activity-activation backend id))))) + +(defun backend-select-view-slot (backend slot) + "Recall a numbered View local to the focused Activity; current View is a no-op." + (let* ((p (current-presentation (x11-backend-world backend) (x11-backend-focused-head-id backend))) + (ids (and p (activity-view-ids (find-activity (x11-backend-world backend) (presentation-activity-id p))))) + (id (first (find-if (lambda (row) (and (= slot (second row)) (member (first row) ids :test #'equal))) + (navigation-state-views (%navigation-state backend)))))) + (when id (%show-navigation-result backend (%ui-request-view-activation backend id))))) diff --git a/src/x11/package.lisp b/src/x11/package.lisp new file mode 100644 index 0000000..fda4ec9 --- /dev/null +++ b/src/x11/package.lisp @@ -0,0 +1,316 @@ +(defpackage #:lime.x11 + (:use #:cl #:lime.core #:lime.ui) + (:documentation + "The small CLX bridge that renders Lime's pure model on one X11 screen.") + (:export + #:backend-open-activity-picker + #:backend-activity-slot + #:backend-view-slot + #:backend-navigation-slots + #:backend-set-activity-slot + #:backend-set-view-slot + #:backend-select-activity-slot + #:backend-select-view-slot + #:backend-switch-to-activity + #:backend-activity-navigation-mode + #:backend-extend-activity-to-head + #:backend-make-activity-portable + #:backend-preflight-activity-switch + #:x11-backend + #:x11-backend-world + #:x11-backend-head-id + #:x11-backend-activity-id + #:x11-backend-focused-head-id + #:x11-backend-configuration + #:x11-backend-configuration-source + #:x11-backend-configuration-name + #:x11-head + #:make-x11-head + #:x11-head-head-id + #:x11-head-x + #:x11-head-y + #:x11-head-width + #:x11-head-height + #:x11-head-output-id + #:x11-head-output-ids + #:x11-head-output-name + #:x11-work-area + #:make-x11-work-area + #:x11-work-area-x + #:x11-work-area-y + #:x11-work-area-width + #:x11-work-area-height + #:x11-head-work-area + #:start-backend + #:stop-backend + #:run-event-loop + #:run-demo + #:manage-window + ;; Diagnostics and explicit recovery (not session persistence). + #:backend-diagnostics + #:backend-record-diagnostic + #:backend-release-input + #:backend-reconcile-after-error + #:backend-save-session + #:backend-session-status + ;; ICCCM client facts. + #:icccm-client-info + #:icccm-client-info-client-id + #:icccm-client-info-window-id + #:icccm-client-info-title + #:icccm-client-info-resource-name + #:icccm-client-info-resource-class + #:icccm-client-info-protocols + #:icccm-client-info-accepts-input-p + #:icccm-client-info-delete-window-p + #:icccm-client-info-take-focus-p + #:icccm-client-info-transient-for-client-id + #:icccm-client-info-normal-hints + #:icccm-client-info-wm-state + #:backend-client-icccm-info + #:icccm-wm-state-data + ;; EWMH metadata that may be useful to a later UI or rule layer. + #:ewmh-client-window-types + ;; Declarative rendering seam. + #:x11-effect + #:make-x11-effect + #:x11-effect-kind + #:x11-effect-client-id + #:x11-effect-geometry + #:x11-effect-border-width + #:x11-effect-border-color + #:window-appearance + #:make-window-appearance + #:window-appearance-border-width + #:window-appearance-focused-border + #:window-appearance-unfocused-border + #:window-appearance-inner-gap + #:window-appearance-outer-gap + #:x11-render-plan + #:make-x11-render-plan + #:x11-render-plan-world-revision + #:x11-render-plan-effects + #:build-render-plan + #:execute-render-plan + #:apply-active-presentation + ;; REPL-friendly command surface. + #:backend-status + #:backend-request-quit + #:backend-head-ids + #:backend-randr-status + #:backend-randr-topology-report + #:backend-build-randr-topology-plan + #:backend-apply-randr-topology-plan + #:backend-reconcile-randr-heads + #:backend-refresh-randr-heads + #:backend-select-head + #:backend-select-relative-head + #:backend-start-activity + #:backend-delete-activity + #:backend-start-named-activity + #:backend-activate-activity + #:backend-preflight-activity-activation + #:backend-save-view + #:backend-save-named-view + #:backend-save-viewset + #:backend-save-named-viewset + #:backend-update-view + #:backend-update-current-view + #:backend-preflight-view-activation + #:backend-activate-view + #:backend-activate-view-strictly + #:backend-activate-view-partially + #:backend-activate-view-taking + #:backend-preflight-viewset-activation + #:backend-activate-viewset + #:backend-activate-viewset-strictly + #:backend-activate-viewset-partially + #:backend-activate-viewset-taking + #:backend-resume-presentation + #:backend-set-layout-root + #:backend-use-master-stack-layout + #:backend-use-monocle-layout + #:backend-use-manual-layout + #:backend-adjust-master-stack-ratio + #:backend-adjust-master-stack-count + #:backend-set-focused-tile-weight + #:backend-adjust-focused-tile-weight + #:backend-cycle-layout + #:backend-promote-focused-client + #:backend-focus-master-client + #:backend-orient-focused-split + #:backend-resize-focused-split + #:backend-swap-focused-client + #:backend-toggle-client-floating + #:backend-toggle-focused-client-floating + #:backend-set-client-floating-geometry + #:backend-hide-client + #:backend-hide-focused-client + #:backend-show-client + #:backend-show-client-taking + #:backend-move-client-to-activity + #:backend-set-client-shared + #:backend-make-client-private + #:backend-focus-client + #:backend-focus-next-client + #:backend-focus-previous-client + #:backend-focus-head-background + #:backend-transfer-focused-client-to-head + #:backend-transfer-focused-client-relatively + #:backend-rehome-client-to-head + #:backend-set-client-fullscreen + #:backend-toggle-focused-client-fullscreen + #:backend-close-client + #:backend-close-focused-client + ;; Process launch boundary: generic shell entry plus the starter commands + ;; matching the user's existing dwm setup. + #:backend-launch-program + #:backend-launch-shell-command + #:backend-launch-terminal + #:backend-launch-browser + ;; Opt-in input bindings. + #:keybinding + #:keybinding-key + #:keybinding-modifiers + #:keybinding-description + #:bind-key + #:unbind-key + #:clear-keybindings + #:list-keybindings + #:backend-last-command-error + ;; User configuration and its first-class command registry. The pleasant + ;; DEFCONFIGURATION surface itself lives in the LIME.CONFIG package. + #:lime-command + #:make-lime-command + #:lime-command-id + #:lime-command-label + #:lime-command-description + #:lime-command-category + #:lime-command-key + #:lime-command-action + #:lime-configuration + #:make-lime-configuration + #:lime-configuration-default-keybindings-p + #:lime-configuration-default-modifiers + #:lime-configuration-default-layout + #:lime-configuration-new-client-focus-p + #:lime-configuration-new-tiled-client-position + #:lime-configuration-close-focus-direction + #:lime-configuration-layout-client-flow-policies + #:layout-client-flow-policy + #:make-layout-client-flow-policy + #:layout-client-flow-policy-layout-mode + #:layout-client-flow-policy-new-tiled-client-position + #:layout-client-flow-policy-close-focus-direction + #:lime-configuration-commands + #:lime-configuration-bindings + #:lime-configuration-rules + #:lime-configuration-appearance + #:lime-configuration-bar-style + #:lime-configuration-font + #:lime-configuration-cursor + #:ui-cursor-style + #:make-ui-cursor-style + #:ui-cursor-style-theme + #:ui-cursor-style-size + #:backend-cursor-report + #:ui-font-style + #:make-ui-font-style + #:ui-font-style-family + #:ui-font-style-size + #:ui-font-style-weight + #:lime-configuration-bar-height + #:lime-configuration-bar-height-supplied-p + #:lime-configuration-status-providers + #:lime-configuration-status-providers-supplied-p + #:lime-configuration-startup-hooks + #:configuration-binding + #:make-configuration-binding + #:configuration-binding-key + #:configuration-binding-modifiers + #:configuration-binding-command-id + #:configuration-binding-description + #:window-rule + #:make-window-rule + #:window-rule-id + #:window-rule-resource-name + #:window-rule-resource-class + #:window-rule-title + #:window-rule-predicate + #:window-rule-float-p + #:window-rule-center-p + #:register-lime-configuration + #:find-lime-configuration + #:load-lime-configuration + #:apply-lime-configuration + #:configure-backend-from-file + #:reload-backend-configuration + #:start-lime + #:list-configured-commands + #:find-configured-command + #:run-configured-command + ;; First UI surface: a Head-local command palette. + #:backend-open-command-palette + #:backend-open-run-prompt + #:backend-open-hidden-client-picker + #:backend-open-view-update-picker + #:backend-send-focused-client-to-head + #:backend-send-focused-client-relatively + #:backend-close-command-palette + #:backend-command-palette-open-p + ;; Reusable Head bar and optional right-side status providers. + #:head-bar-style + #:make-head-bar-style + #:head-bar-style-padding-x + #:head-bar-style-background + #:head-bar-style-foreground + #:head-bar-style-focused-background + #:head-bar-style-focused-foreground + #:head-bar-style-unfocused-background + #:head-bar-style-unfocused-foreground + #:head-bar-style-accent-color + #:head-bar-style-menu-label-color + #:head-bar-style-logo-color + #:head-bar-style-separator-color + #:head-bar-style-attention-color + #:head-bar-style-attention-marker + #:head-bar-style-attention-indicator-p + #:backend-client-needs-attention-p + #:backend-attention-client-ids + #:backend-open-attention-picker + #:backend-attend-client + #:head-bar-style-title-edge-color + #:head-bar-segment + #:make-head-bar-segment + #:head-bar-segment-id + #:head-bar-segment-text + #:head-bar-segment-maximum-width + #:head-bar-segment-foreground + #:head-bar-segment-prefix-length + #:head-bar-segment-prefix-foreground + #:head-bar-segment-click-action + #:backend-set-head-bar-height + #:backend-set-head-bar-status-providers + #:status-provider + #:make-status-provider + #:status-provider-id + #:status-provider-formatter + #:status-provider-foreground + #:status-publish + #:status-wait + #:status-cancelled-p + #:backend-status-provider-report + #:make-clock-status-provider + #:make-volume-status-provider + #:make-music-status-provider + #:format-music-status + #:format-volume-status + #:format-clock-status + #:backend-cycle-music-source + #:backend-music-command + ;; Opt-in starter keymap and named configuration helpers. + #:install-default-keybindings + #:bind-head-key + #:bind-view-key + #:bind-viewset-key + #:bind-activity-key)) diff --git a/src/x11/persistence.lisp b/src/x11/persistence.lisp new file mode 100644 index 0000000..15e24f8 --- /dev/null +++ b/src/x11/persistence.lisp @@ -0,0 +1,319 @@ +(in-package #:lime.x11) + +;;;; X11 identity/reconnection and owner-thread snapshot scheduling. The disk +;;;; worker receives plain immutable data only, never the world or CLX display. + +(defstruct session-persistence + store file epoch + (tokens (make-hash-table :test #'equal)) + restored-clients + restore-report restore-error snapshot-error (blocked-p nil) blocked-reason + (lock (bt:make-lock "Lime session writer")) + (work-ready (bt:make-condition-variable)) + (work-done (bt:make-condition-variable)) + thread (running-p t) pending + (submitted 0) (completed 0) write-error last-save-time + observed-signature dirty-since changed-at last-attempt) + +(defun %session-token () + (with-open-file (stream #p"/dev/urandom" :element-type '(unsigned-byte 8)) + (format nil "~{~2,'0X~}" (loop repeat 16 collect (read-byte stream))))) + +(defun %session-token-p (token) + (and (stringp token) (= 32 (length token)) + (every (lambda (c) (digit-char-p c 16)) token))) + +(defun %read-session-token (window property) + (multiple-value-bind (bytes type format) + (xlib:get-property window property :type :STRING :end 33 :result-type 'vector) + (declare (ignore type)) + (when (and bytes (eql format 8) (= 32 (length bytes))) + (let ((token (map 'string #'code-char bytes))) + (and (%session-token-p token) token))))) + +(defun %ensure-session-token (window property) + (or (%read-session-token window property) + (let ((token (%session-token))) + (xlib:change-property window property (map 'vector #'char-code token) :STRING 8) + token))) + +(defun %session-note-client (backend id window) + (let ((state (x11-backend-session-persistence backend))) + (when (and state (session-persistence-store state)) + (setf (gethash id (session-persistence-tokens state)) + (%ensure-session-token window :_LIME_SESSION_CLIENT))))) + +(defun %session-forget-client (backend id) + (let ((state (x11-backend-session-persistence backend))) + (when state (remhash id (session-persistence-tokens state))))) + +(defun %session-worker (state) + (loop + (let ((work + (bt:with-lock-held ((session-persistence-lock state)) + (loop while (and (session-persistence-running-p state) + (null (session-persistence-pending state))) + do (bt:condition-wait (session-persistence-work-ready state) + (session-persistence-lock state))) + (when (and (null (session-persistence-pending state)) + (not (session-persistence-running-p state))) (return-from %session-worker)) + (prog1 (session-persistence-pending state) + (setf (session-persistence-pending state) nil))))) + (let ((failure nil)) + (handler-case (lime.persistence:write-session-store (session-persistence-store state) (cdr work)) + (error (c) (setf failure (%diagnostic-condition-message c)))) + (bt:with-lock-held ((session-persistence-lock state)) + (setf (session-persistence-completed state) (car work) + (session-persistence-write-error state) failure) + (unless failure (setf (session-persistence-last-save-time state) (get-universal-time))) + (bt:condition-notify (session-persistence-work-done state))))))) + +(defun %validate-session-envelope (data) + (lime.persistence:check-record data (append '(:format :version :world :server-token :clients :focused-head :focus-root) + (when (member (getf data :version) '(2 3)) '(:navigation)) + (when (eql 3 (getf data :version)) '(:activity-navigation)))) + (unless (and (eq :lime-session (getf data :format)) (member (getf data :version) '(1 2 3)) + (%session-token-p (getf data :server-token)) + (member (getf data :focus-root) '(t nil))) + (error "Unsupported or malformed Lime session file.")) + (let ((world (lime.persistence:restore-world (getf data :world) :normalize-arrangements-p nil)) + (ids nil) (xids nil) (tokens nil)) + (dolist (row (getf data :clients)) + (lime.persistence:check-record row '(:id :xid :token :border-width)) + (let ((id (getf row :id)) (xid (getf row :xid)) (token (getf row :token))) + (find-client world id) + (unless (and (typep xid '(integer 1 #xffffffff)) (%session-token-p token) + (typep (getf row :border-width) '(integer 0 65535)) + (not (member id ids :test #'equal)) (not (member xid xids)) + (not (member token tokens :test #'equal))) + (error "Invalid/duplicate saved X11 client identity.")) + (push id ids) (push xid xids) (push token tokens))) + (unless (= (length ids) (hash-table-count (lime.core::world-clients world))) + (error "Session identity list does not cover the saved client pool.")) + (when (getf data :focused-head) (find-head world (getf data :focused-head))) + (let ((navigation (when (member (getf data :version) '(2 3)) + (%navigation-read-data (getf data :navigation) world)))) + (when (< (getf (getf data :world) :version) 3) + (normalize-activity-arrangements + world :preferred-presentation-ids (and navigation (mapcar #'third (navigation-state-resume navigation)))) + (when navigation + (setf (navigation-state-resume navigation) + (loop for row in (navigation-state-resume navigation) + for head = (first row) for activity = (second row) + for p = (activity-draft-for-head world activity head) + when p collect (list head activity (presentation-id p)))))) + (validate-world world) + (values world navigation + (if (eql 3 (getf data :version)) + (%activity-navigation-read-data (getf data :activity-navigation) world) + ;; Infer before missing clients/topology are pruned. A reboot + ;; must not erase an old Activity's genuine multi-Head intent. + (make-activity-navigation-state + :world world :rows (mapcar (lambda (a) (%infer-activity-navigation-row world (activity-id a))) + (list-activities world)))))))) + +(defun %prepare-session-persistence (backend file) + "Restore a fully validated candidate before bootstrapping/adopting any clients." + (when file + (let* ((state (make-session-persistence)) + (path (if (eq file :default) + (lime.persistence:default-session-path (x11-backend-display-name backend)) file))) + (setf (x11-backend-session-persistence backend) state + (session-persistence-file state) (pathname path)) + (handler-case + (let* ((store (setf (session-persistence-store state) (lime.persistence:open-session-store path))) + (epoch (%ensure-session-token (x11-backend-root backend) :_LIME_SESSION_SERVER)) + (data (lime.persistence:read-session-store store))) + (setf (session-persistence-epoch state) epoch) + (when data + (let* ((validated (multiple-value-list (%validate-session-envelope data))) + (world (first validated)) + (navigation (second validated)) + (activity-navigation (third validated)) + (same-server (equal epoch (getf data :server-token))) + (children (xlib:query-tree (x11-backend-root backend))) + (matched nil) (missing nil)) + (dolist (row (getf data :clients)) + (let ((window (and same-server (find (getf row :xid) children :key #'xlib:window-id)))) + ;; Never reconnect by title, class, PID, or XID alone. Also + ;; reject withdrawn/unmanaged windows, including stale tags. + (if (and window + (handler-case + (and (not (eq :on (xlib:window-override-redirect window))) + (equal (getf row :token) (%read-session-token window :_LIME_SESSION_CLIENT)) + (or (eq :viewable (xlib:window-map-state window)) + (member (first (xlib:get-property window :WM_STATE :type :WM_STATE)) '(1 3)))) + (x11-client-disappeared () nil))) + (push (cons row window) matched) + (progn (push (getf row :id) missing) (retire-client world (getf row :id)))))) + ;; Removed Heads keep suspended drafts. No guessed move onto a + ;; different monitor, and no leases remain on absent hardware. + (let ((plan (build-head-topology-reconciliation-plan + (preflight-head-topology-reconciliation world (backend-head-ids backend))))) + (commit-head-topology-reconciliation-plan world plan)) + (validate-world world) + (setf (x11-backend-world backend) world + (session-persistence-restored-clients state) (reverse matched) + (session-persistence-restore-report state) + (list :matched (length matched) :missing (nreverse missing) :same-server-p same-server)) + (when navigation (setf (gethash backend *backend-navigation-states*) navigation)) + (when activity-navigation + (setf (gethash backend *backend-activity-navigation-states*) activity-navigation)) + (when (member (getf data :focused-head) (backend-head-ids backend) :test #'equal) + (setf (x11-backend-focused-head-id backend) (getf data :focused-head) + (x11-backend-focus-root-override-p backend) (getf data :focus-root)))))) + (error (c) + ;; Keep an invalid file intact; don't silently overwrite it with a + ;; fresh desk. The WM can still start, with persistence blocked. + (setf (session-persistence-blocked-p state) t + (session-persistence-blocked-reason state) :restore + (session-persistence-restore-error state) (%diagnostic-condition-message c)) + (backend-record-diagnostic backend c :source :session-restore) + (format *error-output* "~&Lime session restore disabled: ~A~%" (%diagnostic-condition-message c)))) + (setf (session-persistence-running-p state) (not (null (session-persistence-store state)))) + (when (session-persistence-store state) + (setf (session-persistence-thread state) + (bt:make-thread (lambda () (%session-worker state)) :name "Lime session writer")))))) + +(defun %adopt-session-clients (backend) + (let ((state (x11-backend-session-persistence backend))) + (when state + (dolist (entry (session-persistence-restored-clients state)) + (%call-with-client-race-handling + backend + (lambda () + (let* ((row (car entry)) (window (cdr entry)) (id (getf row :id))) + (%register-window backend id window) + (setf (gethash id (session-persistence-tokens state)) (getf row :token) + (gethash id (x11-backend-original-border-widths backend)) (getf row :border-width)) + (icccm-adopt-client backend id window) + ;; Rehydrate the visibility cache from X, not :WITHDRAWN. Hiding + ;; an already-unmapped restored client emits no UnmapNotify; an + ;; artificial pending-unmap token would swallow its later real + ;; withdrawal. Publish the state matching its physical mapping, + ;; then let the normal renderer apply the saved desk selection. + (icccm-set-client-state backend id window + (if (eq :viewable (xlib:window-map-state window)) :normal :iconic) + :force-p t) + (ewmh-adopt-client backend id window) + (pointer-adopt-client backend window) + ;; Fullscreen remains adapter state read afresh from the client. + (when (ewmh-window-requests-fullscreen-p backend window) + (setf (gethash id (x11-backend-fullscreen-clients backend)) t)))))) + (setf (session-persistence-restored-clients state) nil)))) + +(defun %session-signature (backend) + (list (world-revision (x11-backend-world backend)) (x11-backend-focused-head-id backend) + (x11-backend-focus-root-override-p backend) + (navigation-state-generation (%navigation-state backend)) + (activity-navigation-state-generation (%activity-navigation-state backend)))) + +(defun %session-snapshot (backend) + (%validate-client-registrations backend) + (let ((state (x11-backend-session-persistence backend))) + (let ((data + (list :format :lime-session :version 3 + :world (lime.persistence:snapshot-world (x11-backend-world backend)) + :navigation (%navigation-snapshot backend) + :activity-navigation (%activity-navigation-snapshot backend) + :server-token (session-persistence-epoch state) + :focused-head (x11-backend-focused-head-id backend) + :focus-root (x11-backend-focus-root-override-p backend) + :clients (loop for id in (%registered-client-ids backend) + for window = (gethash id (x11-backend-client-windows backend)) + collect (list :id id :xid (xlib:window-id window) + :token (gethash id (session-persistence-tokens state)) + :border-width (gethash id (x11-backend-original-border-widths backend) 0)))))) + ;; Validate cached/inactive drafts too; a file we write must be readable. + (%validate-session-envelope data) + (lime.persistence:copy-data data)))) + +(defun backend-save-session (backend &key (wait-p t) replace-invalid-p) + "Explicitly save the current desk. Must be called on the X owner thread. + +REPLACE-INVALID-P authorizes overwriting a file rejected during startup. Ordinary +autosave never does this. WAIT-P waits for disk completion and reports failures." + (let ((state (x11-backend-session-persistence backend))) + (unless (and state (session-persistence-store state) (session-persistence-running-p state)) + (error "Session persistence is not enabled for this backend.")) + (when (and (session-persistence-blocked-p state) + (eq :restore (session-persistence-blocked-reason state)) (not replace-invalid-p)) + (error "Session autosave is blocked after a restore error; inspect BACKEND-SESSION-STATUS first.")) + (let ((data (%session-snapshot backend))) + (bt:with-lock-held ((session-persistence-lock state)) + (let ((generation (incf (session-persistence-submitted state)))) + (setf (session-persistence-pending state) (cons generation data) + (session-persistence-blocked-p state) nil + (session-persistence-blocked-reason state) nil + (session-persistence-snapshot-error state) nil + (session-persistence-observed-signature state) (%session-signature backend) + (session-persistence-last-attempt state) (/ (get-internal-real-time) internal-time-units-per-second) + (session-persistence-dirty-since state) nil) + (bt:condition-notify (session-persistence-work-ready state)) + (when wait-p + (loop while (< (session-persistence-completed state) generation) + do (bt:condition-wait (session-persistence-work-done state) (session-persistence-lock state))) + (when (session-persistence-write-error state) (error "Session save failed: ~A" (session-persistence-write-error state))))))) + (backend-session-status backend))) + +(defun %poll-session-persistence (backend) + "Cheap change detection, with a .75s quiet period / 5s maximum dirty age." + (let ((state (x11-backend-session-persistence backend))) + (when (and state (session-persistence-store state) (not (session-persistence-blocked-p state))) + (let ((signature (%session-signature backend)) + (now (/ (get-internal-real-time) internal-time-units-per-second))) + ;; Retry failed disk writes with backoff, even if no new edit arrives. + ;; Healthy unchanged sessions perform no snapshot or disk work. + (when (and (session-persistence-write-error state) + (session-persistence-last-attempt state) + (>= (- now (session-persistence-last-attempt state)) 5) + (null (session-persistence-dirty-since state))) + (setf (session-persistence-dirty-since state) (- now 5) + (session-persistence-changed-at state) now)) + (unless (equal signature (session-persistence-observed-signature state)) + (setf (session-persistence-observed-signature state) signature + (session-persistence-changed-at state) now) + (unless (session-persistence-dirty-since state) (setf (session-persistence-dirty-since state) now))) + (when (and (session-persistence-dirty-since state) (not (x11-backend-pointer-drag backend)) + (or (>= (- now (session-persistence-changed-at state)) 3/4) + (>= (- now (session-persistence-dirty-since state)) 5))) + (handler-case (backend-save-session backend :wait-p nil) + (error (c) + (setf (session-persistence-blocked-p state) t + (session-persistence-blocked-reason state) :snapshot + (session-persistence-snapshot-error state) (%diagnostic-condition-message c)) + (backend-record-diagnostic backend c :source :session-save)))))))) + +(defun backend-session-status (backend) + (let ((state (x11-backend-session-persistence backend))) + (if (null state) (list :enabled-p nil) + (bt:with-lock-held ((session-persistence-lock state)) + (list :enabled-p (not (null (session-persistence-store state))) + :running-p (session-persistence-running-p state) + :file (if (session-persistence-store state) + (lime.persistence:session-store-path (session-persistence-store state)) + (session-persistence-file state)) + :blocked-p (session-persistence-blocked-p state) + :blocked-reason (session-persistence-blocked-reason state) + :restore (copy-tree (session-persistence-restore-report state)) + :restore-error (session-persistence-restore-error state) + :snapshot-error (session-persistence-snapshot-error state) + :write-error (session-persistence-write-error state) + :last-save-time (session-persistence-last-save-time state) + :submitted (session-persistence-submitted state) :completed (session-persistence-completed state)))))) + +(defun %stop-session-persistence (backend save-p) + (let ((state (x11-backend-session-persistence backend))) + (when (and state (session-persistence-store state) (session-persistence-running-p state)) + (unwind-protect + (when (and save-p (not (session-persistence-blocked-p state))) + (handler-case (backend-save-session backend) + (error (c) + (format *error-output* "~&Lime session save failed at shutdown: ~A~%" + (%diagnostic-condition-message c)) + (error c)))) + (bt:with-lock-held ((session-persistence-lock state)) + (setf (session-persistence-running-p state) nil) + (bt:condition-notify (session-persistence-work-ready state))) + (when (session-persistence-thread state) (bt:join-thread (session-persistence-thread state))) + (lime.persistence:close-session-store (session-persistence-store state)))))) diff --git a/src/x11/placement-policy.lisp b/src/x11/placement-policy.lisp new file mode 100644 index 0000000..08d81ef --- /dev/null +++ b/src/x11/placement-policy.lisp @@ -0,0 +1,183 @@ +(in-package #:lime.x11) + +;;;; New-client placement policy +;;; +;;; This is intentionally an adapter policy, not a model transition. A +;;; transient dialog still becomes an ordinary placement and lease; the policy +;;; merely picks its initial Head, Presentation, and floating rectangle. + +(defstruct x11-placement-decision + head-id + presentation-id + activity-id + (kind :tile) + data + transient-for-client-id + ;; A transient parent and a dialog-like EWMH type both need an immediately + ;; usable input target after being mapped. This is frontend placement + ;; policy, never saved Activity/View state. + (focus-p nil)) + +(defun %active-presentation-for-client (backend client-id) + "Return CLIENT-ID's active leased Presentation, or NIL when it is parked." + (let ((lease (lease-for-client (x11-backend-world backend) client-id))) + (when lease + (let ((presentation (find-presentation + (x11-backend-world backend) + (lease-presentation-id lease)))) + (and (presentation-active-p (x11-backend-world backend) presentation) + presentation))))) + +(defun %window-geometry (window) + (make-geometry :x (xlib:drawable-x window) + :y (xlib:drawable-y window) + :width (max 1 (xlib:drawable-width window)) + :height (max 1 (xlib:drawable-height window)))) + +(defun %centered-over-parent-geometry (geometry parent-window) + (if parent-window + (make-geometry + :x (+ (xlib:drawable-x parent-window) + (floor (- (xlib:drawable-width parent-window) + (geometry-width geometry)) + 2)) + :y (+ (xlib:drawable-y parent-window) + (floor (- (xlib:drawable-height parent-window) + (geometry-height geometry)) + 2)) + :width (geometry-width geometry) + :height (geometry-height geometry)) + geometry)) + +(defun %floating-data-for-window (backend client-id window head parent-window) + "Build a canonical Head-relative float rectangle for WINDOW. + +The dialog's requested size is first constrained to its hints, then centered +over its managed parent where possible. Bounds keep the final rectangle inside +the target Head before it reaches the pure model." + (let* ((work-area (x11-head-work-area backend head)) + (sized (constrain-client-geometry backend client-id + (%window-geometry window) + :work-area work-area)) + (centered (%centered-over-parent-geometry sized parent-window)) + (geometry (constrain-client-geometry backend client-id centered + :work-area work-area)) + (work-width (x11-work-area-width work-area)) + (work-height (x11-work-area-height work-area))) + (list :x (/ (- (geometry-x geometry) (x11-work-area-x work-area)) work-width) + :y (/ (- (geometry-y geometry) (x11-work-area-y work-area)) work-height) + :width (/ (geometry-width geometry) work-width) + :height (/ (geometry-height geometry) work-height)))) + +(defun %centered-floating-data-for-window (backend client-id window head) + "Build a canonical centered float rectangle for an ordinary matched window. + +This is intentionally separate from the transient helper above. A transient +centers over its parent when possible; a configuration rule's `:CENTER T` +means center inside the selected Head's ordinary work area instead." + (let* ((work-area (x11-head-work-area backend head)) + (sized (constrain-client-geometry backend client-id + (%window-geometry window) + :work-area work-area)) + (centered + (make-geometry + :x (+ (x11-work-area-x work-area) + (floor (- (x11-work-area-width work-area) + (geometry-width sized)) + 2)) + :y (+ (x11-work-area-y work-area) + (floor (- (x11-work-area-height work-area) + (geometry-height sized)) + 2)) + :width (geometry-width sized) + :height (geometry-height sized))) + (geometry (constrain-client-geometry backend client-id centered + :work-area work-area)) + (work-width (x11-work-area-width work-area)) + (work-height (x11-work-area-height work-area))) + (list :x (/ (- (geometry-x geometry) (x11-work-area-x work-area)) work-width) + :y (/ (- (geometry-y geometry) (x11-work-area-y work-area)) work-height) + :width (/ (geometry-width geometry) work-width) + :height (/ (geometry-height geometry) work-height)))) + +(defun %fixed-size-normal-hints-p (hints) + "True only when both axes explicitly declare one positive allowed size." + (when hints + (let ((min-width (xlib:wm-size-hints-min-width hints)) + (min-height (xlib:wm-size-hints-min-height hints)) + (max-width (xlib:wm-size-hints-max-width hints)) + (max-height (xlib:wm-size-hints-max-height hints))) + (and (every (lambda (value) (and (integerp value) (plusp value))) + (list min-width min-height max-width max-height)) + (= min-width max-width) + (= min-height max-height))))) + +(declaim (ftype function apply-configured-window-rules)) + +(defun new-client-placement-decision (backend client-id window) + "Choose an initial target for a newly managed client. + +A managed WM_TRANSIENT_FOR parent makes the child a float on that parent's +active Head, even if the user most recently selected another Head. EWMH +dialog/utility/splash types receive the same centered floating default on the +focused Head. Ordinary fixed-size clients also default to centered floats, +subject to configured rules; other clients retain the normal tiled default. +This policy runs only at adoption, not on later normal-hints changes." + (let* ((world (x11-backend-world backend)) + (info (backend-client-icccm-info backend client-id)) + (parent-client-id + (and info (icccm-client-info-transient-for-client-id info))) + (parent-presentation + (and parent-client-id + (%active-presentation-for-client backend parent-client-id)))) + (if parent-presentation + ;; Modal/transient placement is an ICCCM guarantee, not a user style + ;; preference: its parent owns the target Head and it must stay float. + (let* ((head-id (presentation-head-id parent-presentation)) + (head (%head-for-id backend head-id)) + (parent-window + (gethash parent-client-id + (x11-backend-client-windows backend)))) + (make-x11-placement-decision + :head-id head-id + :presentation-id (presentation-id parent-presentation) + :activity-id (presentation-activity-id parent-presentation) + :kind :float + :data (%floating-data-for-window backend client-id window head + parent-window) + :transient-for-client-id parent-client-id + :focus-p t)) + ;; Dialog-like EWMH windows do not always set WM_TRANSIENT_FOR. They + ;; still deserve the conservative non-tiling placement familiar from + ;; traditional WMs, but have no invented parent Activity or Head. + (let* ((head-id (x11-backend-focused-head-id backend)) + (presentation (current-presentation world head-id))) + (unless presentation + (error 'invalid-transition + :description + "The selected Head is blank; start or mount an Activity before opening a window there.")) + (if (ewmh-client-dialog-like-p backend client-id) + (let ((head (%head-for-id backend head-id))) + (make-x11-placement-decision + :head-id head-id + :presentation-id (presentation-id presentation) + :activity-id (presentation-activity-id presentation) + :kind :float + :data (%centered-floating-data-for-window backend client-id window head) + :focus-p t)) + ;; Fixed-size ordinary clients (often startup/updater windows) + ;; cannot fill a tile. Float them without a class-wide rule that + ;; would also catch the application's resizable main window. + ;; Unlike dialogs, they retain the configured focus policy. + (let ((fixed-p (%fixed-size-normal-hints-p + (and info (icccm-client-info-normal-hints info))))) + (apply-configured-window-rules + backend client-id window + (make-x11-placement-decision + :head-id head-id + :presentation-id (presentation-id presentation) + :activity-id (presentation-activity-id presentation) + :kind (if fixed-p :float :tile) + :data (when fixed-p + (%centered-floating-data-for-window + backend client-id window (%head-for-id backend head-id))))))))))) diff --git a/src/x11/pointer.lisp b/src/x11/pointer.lisp new file mode 100644 index 0000000..5bf1118 --- /dev/null +++ b/src/x11/pointer.lisp @@ -0,0 +1,285 @@ +(in-package #:lime.x11) + +;;;; Pointer routing +;;; +;;; A pointer event is only evidence about where the user acted. This layer +;;; resolves it to a Head/client and delegates focus state to the command +;;; surface, keeping input delivery separate from leases, ICCCM, and layouts. + +(declaim (ftype function x11-backend-hand-cursor)) + +(defun %set-ui-pointer (backend window clickable-p previous-hand-p) + "Update only this UI window, reusing the shared cursor and skipping no-ops." + (let ((hand-p (not (null clickable-p)))) + (unless (eq hand-p previous-hand-p) + (setf (xlib:window-cursor window) + (if hand-p (x11-backend-hand-cursor backend) :none)) + ;; Bar motion does not repaint; don't wait for the next event to flush. + (xlib:display-force-output (x11-backend-display backend))) + hand-p)) + +(defun %ui-window-pointer-position (backend window) + "Return local (X . Y) only if WINDOW is actually under the pointer. + +This is a redraw-time snapshot, not a polling timer. Checking the root child +also excludes UI hidden by another window, not just points outside its bounds." + (multiple-value-bind (x y same-screen-p child) + (xlib:query-pointer (x11-backend-root backend)) + (when (and same-screen-p child (= (xlib:window-id child) (xlib:window-id window))) + (cons (- x (xlib:drawable-x window)) (- y (xlib:drawable-y window)))))) + +(defstruct pointer-drag + "A transient X11 pointer gesture expressed against one floating placement." + client-id + head-id + presentation-id + mode + initial-root-x + initial-root-y + initial-data) + +(defun %head-at-root-position (backend root-x root-y) + "Return the configured Head containing ROOT-X, ROOT-Y, or NIL for a gap." + (find-if + (lambda (head-id) + (let ((head (%head-for-id backend head-id))) + (and (<= (x11-head-x head) root-x) + (< root-x (+ (x11-head-x head) (x11-head-width head))) + (<= (x11-head-y head) root-y) + (< root-y (+ (x11-head-y head) (x11-head-height head)))))) + (x11-backend-head-ids backend))) + +(defun %visible-client-head-id (backend client-id) + "Return the active Head currently leasing CLIENT-ID, if any." + (let* ((world (x11-backend-world backend)) + (lease (lease-for-client world client-id))) + (when lease + (let ((presentation (find-presentation + world (lease-presentation-id lease)))) + (when (presentation-active-p world presentation) + (presentation-head-id presentation)))))) + +(defun pointer-adopt-client (backend window) + "Install Lime's click focus and Super-drag passive grabs on WINDOW. + +The passive grab is necessary because ordinary applications place their actual +content in child windows and select their own ButtonPress events there. With +OWNER-P false, X reports such a press to the grab owner using WINDOW as its +event window, so the backend can reliably find the managed client. It is +intentionally a grab rather than a WINDOW event-mask selection: the latter can +conflict with a client's own ButtonPress selection." + ;; Freeze an ordinary unmodified Button1 so the handler can focus first, + ;; then replay the same press to the application. A separate, more specific + ;; Super grab owns move/resize; :ANY cannot coexist with that X11 grab. + (xlib:grab-button window 1 '(:button-press) :modifiers 0 + :sync-pointer-p t) + ;; Geometry drags are intentionally opt-in via Super. Once the press starts, + ;; MotionNotify and ButtonRelease continue through the active pointer grab. + (xlib:grab-button window 1 '(:button-press :button-release :pointer-motion) + :modifiers '(:mod-4) :sync-pointer-p t) + ;; Keep the user's dwm convention: Super+middle-click changes only this + ;; client's tile/float placement. It is synchronous so we can focus it and + ;; release the click without forwarding a WM gesture to the client. + (xlib:grab-button window 2 '(:button-press) :modifiers '(:mod-4) + :sync-pointer-p t) + (xlib:grab-button window 3 '(:button-press :button-release :pointer-motion) + :modifiers '(:mod-4) :sync-pointer-p t) + backend) + +(defun pointer-forget-client (backend client-id) + "Cancel a drag when CLIENT-ID is retired while its button is down." + (let ((drag (x11-backend-pointer-drag backend))) + (when (and drag (equal (pointer-drag-client-id drag) client-id)) + (setf (x11-backend-pointer-drag backend) nil))) + backend) + +(defun %super-held-p (state) + (not (zerop (logand state (xlib:make-state-mask :mod-4))))) + +(defun %begin-floating-drag (backend client-id head-id mode root-x root-y time) + "Focus CLIENT-ID, then begin a synchronous Super move or resize if it floats." + (unwind-protect + (progn + (backend-focus-client backend client-id :head-id head-id) + (let* ((presentation (current-presentation (x11-backend-world backend) + head-id)) + (placement (and presentation + (find client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal)))) + (when (and placement (eq (placement-kind placement) :float) + (not (equal client-id + (ewmh-fullscreen-client-id-for-head backend head-id)))) + (setf (x11-backend-pointer-drag backend) + (make-pointer-drag + :client-id client-id :head-id head-id :mode mode + :presentation-id (presentation-id presentation) + :initial-root-x root-x :initial-root-y root-y + :initial-data (copy-list (placement-data placement))))))) + ;; Super presses are a WM gesture, never replayed to the client. Releasing + ;; the synchronous grab here lets the active grab deliver its motion/release. + (xlib:allow-events (x11-backend-display backend) :async-pointer time))) + +(defun %clamp (value minimum maximum) + (max minimum (min maximum value))) + +(defun %drag-geometry (drag work-area root-x root-y) + "Return DRAG's new normalized geometry at ROOT-X, ROOT-Y in WORK-AREA." + (let* ((data (pointer-drag-initial-data drag)) + (initial-x (getf data :x)) + (initial-y (getf data :y)) + (initial-width (getf data :width)) + (initial-height (getf data :height)) + (delta-x (/ (- root-x (pointer-drag-initial-root-x drag)) + (max 1 (x11-work-area-width work-area)))) + (delta-y (/ (- root-y (pointer-drag-initial-root-y drag)) + (max 1 (x11-work-area-height work-area))))) + (ecase (pointer-drag-mode drag) + (:move + (list :x (%clamp (+ initial-x delta-x) 0 (- 1 initial-width)) + :y (%clamp (+ initial-y delta-y) 0 (- 1 initial-height)) + :width initial-width :height initial-height)) + (:resize + (let* ((maximum-width (- 1 initial-x)) + (maximum-height (- 1 initial-y)) + ;; A far-right or far-bottom float can legitimately be smaller + ;; than the usual 5% minimum, so cap that minimum by its bounds. + (minimum-width (min 1/20 maximum-width)) + (minimum-height (min 1/20 maximum-height))) + (list :x initial-x :y initial-y + :width (%clamp (+ initial-width delta-x) + minimum-width maximum-width) + :height (%clamp (+ initial-height delta-y) + minimum-height maximum-height))))))) + +(defun %coalesce-drag-motion (backend window root-x root-y state) + "Consume only consecutive, already queued motion for the same pointer gesture. + +Never search past a release, command, lifecycle event, or another window's +motion. The bounded batch avoids starving the developer mailbox under a flood. +CLX's nested event reader starts after the event currently being dispatched." + (let ((display (x11-backend-display backend))) + (loop repeat (min 256 (or (xlib:event-listen display) 0)) + while + (eq :motion + (xlib:event-case (display :timeout 0 :peek-p t :discard-p nil + :force-output-p nil) + (:motion-notify ((window next-window) (root-x next-x) + (root-y next-y) (state next-state)) + (if (and (= (xlib:window-id window) (xlib:window-id next-window)) + (= state next-state)) + (progn + (setf root-x next-x root-y next-y) + (xlib:discard-current-event display) + :motion) + :boundary)) + (otherwise () :boundary))))) + (values root-x root-y)) + +(defun %drag-current-placement (backend drag) + "A gesture cannot follow its client into another draft, Head, or fullscreen." + (let* ((presentation (current-presentation + (x11-backend-world backend) (pointer-drag-head-id drag))) + (client-id (pointer-drag-client-id drag))) + (when (and presentation + (equal (presentation-id presentation) (pointer-drag-presentation-id drag)) + (equal (%visible-client-head-id backend client-id) (pointer-drag-head-id drag)) + (gethash client-id (x11-backend-client-windows backend)) + (not (equal client-id + (ewmh-fullscreen-client-id-for-head backend (pointer-drag-head-id drag))))) + (let ((placement (find client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal))) + (when (and placement (eq :float (placement-kind placement))) placement))))) + +(defun %handle-motion-notify (backend root-x root-y state) + "Apply the current floating gesture's latest Head-relative rectangle." + (declare (ignore state)) + (let ((drag (x11-backend-pointer-drag backend))) + (when drag + (handler-case + (let ((placement (%drag-current-placement backend drag))) + (if (null placement) + (setf (x11-backend-pointer-drag backend) nil) + (let* ((work-area (x11-head-work-area backend (pointer-drag-head-id drag))) + (data (%drag-geometry drag work-area root-x root-y))) + ;; Repeated/clamped coordinates do not dirty a checkpoint or + ;; send redundant ConfigureWindow requests. + (unless (every (lambda (key) + (= (getf data key) (getf (placement-data placement) key))) + '(:x :y :width :height)) + (backend-set-client-floating-geometry + backend (pointer-drag-client-id drag) + :head-id (pointer-drag-head-id drag) + :x (getf data :x) :y (getf data :y) + :width (getf data :width) :height (getf data :height)))))) + (error (condition) + ;; An asynchronously destroyed client or an invalidated gesture must + ;; not take down the event loop. Keep the failure inspectable. + (setf (x11-backend-last-command-error backend) condition + (x11-backend-pointer-drag backend) nil))))) + nil) + +(defun %handle-button-release (backend button &optional root-x root-y) + "Apply the release's final position, then end the matching pointer gesture." + (let ((drag (x11-backend-pointer-drag backend))) + (when (and drag + (or (and (eq (pointer-drag-mode drag) :move) (= button 1)) + (and (eq (pointer-drag-mode drag) :resize) (= button 3)))) + (unwind-protect + (when (and root-x root-y) + (%handle-motion-notify backend root-x root-y 0)) + (setf (x11-backend-pointer-drag backend) nil)))) + nil) + +(defun %handle-button-press (backend window root-x root-y button state time) + "Apply Lime's initial, deliberately boring click-to-focus policy. + +An unmodified Button1 focuses and replays to the app. Super+Button1 moves a +floating client; Super+Button2 toggles this client's floating placement; and +Super+Button3 resizes it. Other buttons remain application input until a +future binding claims them." + (let ((client-id (%backend-client-id backend window))) + (cond + ((and client-id (%super-held-p state) (= button 2)) + (let ((head-id (%visible-client-head-id backend client-id))) + (unwind-protect + (when head-id + (backend-focus-client backend client-id :head-id head-id) + (backend-toggle-client-floating backend client-id :head-id head-id)) + (xlib:allow-events (x11-backend-display backend) + :async-pointer time)))) + ((and client-id (%super-held-p state) (member button '(1 3))) + (let ((head-id (%visible-client-head-id backend client-id))) + (if head-id + (%begin-floating-drag backend client-id head-id + (if (= button 1) :move :resize) + root-x root-y time) + ;; The passive grab can race a lease change. It is still a + ;; synchronous grab and must be released even though no gesture + ;; can safely start. + (xlib:allow-events (x11-backend-display backend) + :async-pointer time)))) + ((= button 1) + (cond + (client-id + (let ((head-id (%visible-client-head-id backend client-id))) + ;; A mapped client should be leased, but stale events are harmless. + ;; Always release the synchronous grab, even if the client changed + ;; state between the event and this lookup or focus signals. + (unwind-protect + (when head-id + (backend-focus-client backend client-id :head-id head-id)) + ;; This client Button1 arrived through our synchronous passive + ;; grab. Reprocess it after focus, bypassing this same grab, so + ;; a browser link or widget still receives the first click. + (xlib:allow-events (x11-backend-display backend) + :replay-pointer + time)))) + ;; CLX normally interns root window objects, but XIDs are the actual + ;; X11 identity and keep this correct if an event arrived through a + ;; different window object. + ((= (xlib:window-id window) + (xlib:window-id (x11-backend-root backend))) + (let ((head-id (%head-at-root-position backend root-x root-y))) + (when head-id + (backend-focus-head-background backend head-id))))))) + t)) diff --git a/src/x11/randr.lisp b/src/x11/randr.lisp new file mode 100644 index 0000000..93a0363 --- /dev/null +++ b/src/x11/randr.lisp @@ -0,0 +1,348 @@ +(in-package #:lime.x11) + +;;;; RandR physical-output discovery +;;; +;;; RandR describes hardware outputs and the CRTCs currently driving them. +;;; Lime renders logical Heads, so an active CRTC is the correct unit: cloned +;;; displays share one CRTC and must not become overlapping Heads. This file +;;; only observes that topology. Deciding how to migrate a task when an +;;; output appears or vanishes remains an explicit higher-level policy. + +(defstruct x11-randr-output + output-id + name + crtc-id + connection + x + y + width + height) + +(defun %x11-randr-active-output-p (output) + (and (eq (x11-randr-output-connection output) :connected) + (plusp (or (x11-randr-output-crtc-id output) 0)) + (plusp (or (x11-randr-output-width output) 0)) + (plusp (or (x11-randr-output-height output) 0)))) + +(defun %x11-randr-output-label (output) + (let ((name (x11-randr-output-name output))) + (if (and (stringp name) (plusp (length name))) + name + (format nil "output-~D" (x11-randr-output-output-id output))))) + +(defun %x11-randr-output-name< (first second) + (string< (%x11-randr-output-label first) + (%x11-randr-output-label second))) + +(defun %x11-head-position< (first second) + (or (< (x11-head-x first) (x11-head-x second)) + (and (= (x11-head-x first) (x11-head-x second)) + (or (< (x11-head-y first) (x11-head-y second)) + (and (= (x11-head-y first) (x11-head-y second)) + (string< (x11-head-head-id first) + (x11-head-head-id second))))))) + +(defun %x11-randr-heads-from-outputs (outputs primary-output-id) + "Make one stable X11-HEAD per active RandR CRTC. + +An output name is a friendlier and more stable user-facing Head id than a +numeric X resource id. When outputs are cloned, PRIMARY-OUTPUT-ID wins as the +representative when present; otherwise the lexically first output name wins. +The retained OUTPUT-IDS records all physical outputs feeding that Head." + (let ((groups (make-hash-table :test #'eql))) + (dolist (output outputs) + (when (%x11-randr-active-output-p output) + (push output (gethash (x11-randr-output-crtc-id output) groups)))) + (let (heads) + (maphash + (lambda (crtc-id group) + (declare (ignore crtc-id)) + (let* ((ordered (sort (copy-list group) #'%x11-randr-output-name<)) + (representative + (or (find primary-output-id ordered + :key #'x11-randr-output-output-id :test #'eql) + (first ordered)))) + (push (make-x11-head + :head-id (%x11-randr-output-label representative) + :x (x11-randr-output-x representative) + :y (x11-randr-output-y representative) + :width (x11-randr-output-width representative) + :height (x11-randr-output-height representative) + :output-id (x11-randr-output-output-id representative) + :output-ids (mapcar #'x11-randr-output-output-id ordered) + :output-name (%x11-randr-output-label representative)) + heads))) + groups) + (sort heads #'%x11-head-position<)))) + +(defun %x11-randr-version-at-least-p (major minor required-major required-minor) + (or (> major required-major) + (and (= major required-major) (>= minor required-minor)))) + +(defun %x11-randr-available-p (display) + (not (null (xlib:query-extension display "RANDR")))) + +(defun x11-randr-discover-topology (display root) + "Return a snapshot of active RandR Heads, or NIL when RandR is unavailable. + +No shell command, root geometry heuristic, or monitor-management request is +used. The snapshot reads active outputs and their CRTCs directly from the X +server, which lets a normal two-monitor desktop and a nested test server use +the same adapter path." + (when (%x11-randr-available-p display) + (multiple-value-bind (major minor) (xlib:rr-query-version display) + (when (%x11-randr-version-at-least-p major minor 1 2) + (multiple-value-bind (timestamp config-timestamp crtcs output-ids modes names) + (xlib:rr-get-screen-resources root) + (declare (ignore crtcs modes names)) + (let* ((primary-output-id + (when (%x11-randr-version-at-least-p major minor 1 3) + (xlib:rr-get-output-primary root))) + (outputs + (loop for output-id in output-ids + for output = (%x11-randr-read-output + display output-id config-timestamp) + when output collect output))) + (make-x11-randr-topology + :major-version major + :minor-version minor + :timestamp timestamp + :config-timestamp config-timestamp + :primary-output-id primary-output-id + :outputs outputs + :heads (%x11-randr-heads-from-outputs outputs primary-output-id)))))))) + +(defun %x11-randr-read-output (display output-id config-timestamp) + "Read one active output and its CRTC rectangle, or return NIL when inactive." + (multiple-value-bind (status output-timestamp crtc-id width-mm height-mm connection + subpixel crtcs preferred-modes modes clones name) + (xlib:rr-get-output-info display output-id config-timestamp) + (declare (ignore output-timestamp width-mm height-mm subpixel crtcs + preferred-modes modes clones)) + (when (and (eq status :success) + (eq connection :connected) + (plusp crtc-id)) + (multiple-value-bind (crtc-status crtc-timestamp x y width height mode + current-rotation possible-rotations outputs possible-outputs) + (xlib:rr-get-crtc-info display crtc-id config-timestamp) + (declare (ignore crtc-timestamp mode current-rotation possible-rotations + outputs possible-outputs)) + (when (and (eq crtc-status :success) (plusp width) (plusp height)) + (make-x11-randr-output :output-id output-id + :name name + :crtc-id crtc-id + :connection connection + :x x :y y :width width :height height)))))) + +(defun x11-randr-enable-notifications (backend) + "Subscribe a RandR-discovered backend to topology-change notifications." + (xlib:rr-select-input + (x11-backend-root backend) + '(:screen-change-notify-mask + :crtc-change-notify-mask + :output-change-notify-mask)) + (xlib:display-force-output (x11-backend-display backend)) + backend) + +(defun %x11-head-signatures (heads) + (mapcar (lambda (head) + (list (x11-head-head-id head) + (x11-head-x head) + (x11-head-y head) + (x11-head-width head) + (x11-head-height head) + (x11-head-output-id head) + (copy-list (x11-head-output-ids head)))) + heads)) + +(defun %same-head-id-set-p (first second) + "Whether two Head-id sequences name the same logical Heads, regardless of order." + (and (= (length first) (length second)) + (every (lambda (head-id) (member head-id second :test #'equal)) first))) + +(defun backend-randr-status (backend) + "Return the observed physical topology without implying a migration policy." + (let ((topology (x11-backend-randr-topology backend))) + (list :head-source (x11-backend-head-source backend) + :topology-dirty-p (x11-backend-randr-topology-dirty-p backend) + :active-head-ids (backend-head-ids backend) + :discovered-head-ids + (and topology + (mapcar #'x11-head-head-id (x11-randr-topology-heads topology))) + :outputs + (and topology + (mapcar (lambda (output) + (list :id (x11-randr-output-output-id output) + :name (%x11-randr-output-label output) + :crtc-id (x11-randr-output-crtc-id output) + :x (x11-randr-output-x output) + :y (x11-randr-output-y output) + :width (x11-randr-output-width output) + :height (x11-randr-output-height output))) + (x11-randr-topology-outputs topology)))))) + +(defun backend-randr-topology-report (backend) + "Return the explicit migration choices for the latest observed RandR topology. + +The embedded :REPORT is a pure HEAD-TOPOLOGY-REPORT: it names retained, +added, and removed logical Heads, plus the live Presentations on removed +Heads. It makes no routing decision and changes neither the model nor X11. +Use BACKEND-BUILD-RANDR-TOPOLOGY-PLAN with explicit moves, then +BACKEND-APPLY-RANDR-TOPOLOGY-PLAN to perform the chosen reconciliation." + (unless (eq (x11-backend-head-source backend) :randr) + (error 'invalid-transition + :description "This backend was not started from RandR-discovered Heads.")) + (let ((topology (x11-backend-randr-topology backend))) + (if (and topology (x11-randr-topology-heads topology)) + (let ((report + (preflight-head-topology-reconciliation + (x11-backend-world backend) + (mapcar #'x11-head-head-id + (x11-randr-topology-heads topology))))) + (list :report report + :topology-dirty-p (x11-backend-randr-topology-dirty-p backend) + :discovered-head-ids + (head-topology-report-desired-head-ids report) + :added-head-ids (head-topology-report-added-head-ids report) + :retained-head-ids (head-topology-report-retained-head-ids report) + :removed-head-ids (head-topology-report-removed-head-ids report) + :removed-active-sources + (head-topology-report-removed-active-sources report))) + (list :report nil + :topology-dirty-p t + :reason (if topology :no-active-heads :randr-unavailable))))) + +(defun backend-build-randr-topology-plan (backend &key moves) + "Build, but do not apply, a RandR topology plan with explicit MOVES. + +MOVES is a list of HEAD-TOPOLOGY-MOVE values. Each move routes a live +Presentation from a disappearing Head to one discovered destination Head. +Any omitted removed source is intentionally suspended; added Heads remain +blank until another ordinary Activity/View command mounts something there." + (let ((report (getf (backend-randr-topology-report backend) :report))) + (or report + (error 'invalid-transition + :description "RandR has no usable topology snapshot to reconcile.")) + (build-head-topology-reconciliation-plan report :moves moves))) + +(declaim (ftype function apply-active-presentation + reconcile-head-bars)) + +(defun %install-randr-head-rectangles (backend heads) + "Replace adapter rectangles only after their Head ids have been proven stable." + ;; Reuse the existing invariant checks before mutating the live backend. + (%configure-heads (x11-backend-root backend) (x11-backend-head-id backend) heads) + (clrhash (x11-backend-heads backend)) + (dolist (head heads) + (setf (gethash (x11-head-head-id head) (x11-backend-heads backend)) head)) + (setf (x11-backend-head-ids backend) (mapcar #'x11-head-head-id heads) + (x11-backend-head-id backend) (x11-head-head-id (first heads))) + backend) + +(defun %sync-focus-after-randr-topology-reconciliation (backend) + "Keep adapter-local input routing on an existing Head after a migration." + (unless (gethash (x11-backend-focused-head-id backend) + (x11-backend-heads backend)) + (setf (x11-backend-focused-head-id backend) + (first (x11-backend-head-ids backend)))) + (let ((presentation + (current-presentation (x11-backend-world backend) + (x11-backend-focused-head-id backend)))) + (setf (x11-backend-activity-id backend) + (and presentation (presentation-activity-id presentation)) + (x11-backend-focus-root-override-p backend) nil)) + backend) + +(defun backend-apply-randr-topology-plan (backend plan) + "Apply an explicit RandR PLAN to the model and current X11 rectangles. + +The adapter rereads RandR immediately before commit. If another output change +altered the desired Head-id set while a frontend was presenting choices, it +refuses the stale plan without moving any Activity, Presentation, or Lease." + (unless (eq (x11-backend-head-source backend) :randr) + (error 'invalid-transition + :description "This backend was not started from RandR-discovered Heads.")) + (unless (typep plan 'head-topology-plan) + (error 'invalid-transition + :description "RandR reconciliation needs a HEAD-TOPOLOGY-PLAN.")) + (let ((topology (x11-randr-discover-topology + (x11-backend-display backend) (x11-backend-root backend)))) + (unless topology + (setf (x11-backend-randr-topology-dirty-p backend) t) + (error 'invalid-transition + :description "RandR became unavailable before topology reconciliation.")) + (let ((heads (x11-randr-topology-heads topology))) + (unless (%same-head-id-set-p + (head-topology-plan-desired-head-ids plan) + (mapcar #'x11-head-head-id heads)) + (setf (x11-backend-randr-topology backend) topology + (x11-backend-randr-topology-dirty-p backend) t) + (error 'stale-transition-plan)) + (let ((result (commit-head-topology-reconciliation-plan + (x11-backend-world backend) plan))) + (%install-randr-head-rectangles backend heads) + (reconcile-head-bars backend) + (setf (x11-backend-randr-topology backend) topology + (x11-backend-randr-topology-dirty-p backend) nil) + (%sync-focus-after-randr-topology-reconciliation backend) + (apply-active-presentation backend) + result)))) + +(defun backend-reconcile-randr-heads (backend &key moves) + "Convenience orchestration for an already-chosen explicit RandR migration. + +Interactive frontends normally keep query, choice, and mutation visibly +separate through BACKEND-RANDR-TOPOLOGY-REPORT, +BACKEND-BUILD-RANDR-TOPOLOGY-PLAN, and BACKEND-APPLY-RANDR-TOPOLOGY-PLAN. +This wrapper is useful for a REPL or IPC caller that has already chosen MOVES." + (backend-apply-randr-topology-plan + backend (backend-build-randr-topology-plan backend :moves moves))) + +(defun backend-refresh-randr-heads (backend) + "Safely apply a same-topology RandR geometry refresh. + +Resolution or position changes with the same Head ids are safe: all existing +Presentations and Leases retain their owners, so Lime replaces only adapter +rectangles and rerenders. Added or removed Heads return a pending report +instead. Use the explicit RandR topology-report/plan/apply commands to make +that migration decision." + (unless (eq (x11-backend-head-source backend) :randr) + (error 'invalid-transition + :description "This backend was not started from RandR-discovered Heads.")) + (let ((topology (x11-randr-discover-topology + (x11-backend-display backend) (x11-backend-root backend)))) + (unless topology + (setf (x11-backend-randr-topology-dirty-p backend) t) + (return-from backend-refresh-randr-heads + (append (backend-randr-status backend) + (list :refreshed-p nil :reason :randr-unavailable)))) + (setf (x11-backend-randr-topology backend) topology) + (let ((heads (x11-randr-topology-heads topology))) + (if (%same-head-id-set-p (mapcar #'x11-head-head-id heads) + (x11-backend-head-ids backend)) + (progn + (%install-randr-head-rectangles backend heads) + (reconcile-head-bars backend) + (setf (x11-backend-randr-topology-dirty-p backend) nil) + (apply-active-presentation backend) + (append (backend-randr-status backend) + (list :refreshed-p t :reason :same-topology))) + (progn + (setf (x11-backend-randr-topology-dirty-p backend) t) + (append (backend-randr-status backend) + (list :refreshed-p nil :reason :topology-changed))))))) + +(defun x11-randr-handle-change (backend) + "Record a RandR event as pending; do not silently migrate task state." + (when (eq (x11-backend-head-source backend) :randr) + (let ((topology (x11-randr-discover-topology + (x11-backend-display backend) (x11-backend-root backend)))) + (setf (x11-backend-randr-topology backend) topology + (x11-backend-randr-topology-dirty-p backend) + (or (null topology) + (not (equal (%x11-head-signatures + (x11-randr-topology-heads topology)) + (%x11-head-signatures + (loop for head-id in (x11-backend-head-ids backend) + collect (%head-for-id backend head-id)))))))) + (backend-randr-status backend))) diff --git a/src/x11/render.lisp b/src/x11/render.lisp new file mode 100644 index 0000000..110fc66 --- /dev/null +++ b/src/x11/render.lisp @@ -0,0 +1,286 @@ +(in-package #:lime.x11) + +;;;; Declarative render planning and imperative X11 execution +;;; +;;; The model never calls CLX. This file is the narrow reconciliation seam: +;;; BUILD-RENDER-PLAN observes a stable Lime world and describes the required +;;; effects; EXECUTE-RENDER-PLAN is the only code here that performs them. +;;; That keeps additions such as stacking, borders, size hints, and +;;; animations from leaking into core transitions or client lifecycle code. + +(defstruct x11-effect + "One X11 operation requested by an X11-RENDER-PLAN. + +KIND is currently :CONFIGURE, :MAP, :UNMAP, :RAISE, :FOCUS, or :FOCUS-ROOT. Effects +refer to Lime client ids so plans remain inspectable without exposing CLX +window objects." + kind + client-id + geometry + (border-width 0) + border-color) + +(defstruct x11-render-plan + "A complete desired reconciliation of Lime's active Presentations to X11." + world-revision + (effects '())) + +(defun %geometry-for-client (geometries client-id) + (cdr (assoc client-id geometries :test #'equal))) + +(defun %active-client-geometries (backend) + "Return content rectangles and, as a second value, their border widths." + (let ((world (x11-backend-world backend)) + (geometries '()) + (borders '())) + (dolist (head-id (x11-backend-head-ids backend)) + (let ((presentation (current-presentation world head-id))) + (when presentation + (let* ((head (%head-for-id backend head-id)) + (work-area (x11-head-work-area backend head)) + (fullscreen-client-id + (ewmh-fullscreen-client-id-for-head backend head-id)) + (layout (resolve-presentation-layout + presentation + (x11-work-area-width work-area) + (x11-work-area-height work-area) + :x (x11-work-area-x work-area) + :y (x11-work-area-y work-area))) + (leased-client-ids (presentation-leased-client-ids world presentation)) + ;; Count what this Head will actually tile, not Activity + ;; membership or saved slots whose leases live elsewhere. + ;; Monocle naturally contributes just its one resolved tile. + (visible-tile-count + (loop for placement in (presentation-placements presentation) + for client-id = (placement-client-id placement) + count (and (eq :tile (placement-kind placement)) + (member client-id leased-client-ids :test #'equal) + (%geometry-for-client layout client-id))))) + (dolist (client-id leased-client-ids) + (let ((geometry + (if (equal client-id fullscreen-client-id) + ;; A genuine fullscreen request intentionally skips + ;; normal-hint adjustment: it owns the complete + ;; configured Head, exactly as a game asks. + (make-geometry :x (x11-head-x head) + :y (x11-head-y head) + :width (x11-head-width head) + :height (x11-head-height head)) + (%geometry-for-client layout client-id)))) + (when geometry + (multiple-value-bind (content border) + (if (equal client-id fullscreen-client-id) + (values geometry 0) + (%styled-client-geometry + backend client-id geometry work-area + (eq :tile + (placement-kind + (find client-id (presentation-placements presentation) + :key #'placement-client-id :test #'equal))) + :visible-tile-count visible-tile-count)) + (push (cons client-id content) geometries) + (push (cons client-id border) borders))))))))) + (values geometries borders))) + +(defun %registered-client-ids (backend) + "Return registered Lime client ids in a stable order for inspectable plans." + (let (client-ids) + (maphash (lambda (client-id window) + (declare (ignore window)) + (push client-id client-ids)) + (x11-backend-client-windows backend)) + (sort client-ids #'string< :key #'princ-to-string))) + +(defun %focused-client-id (backend geometries) + "Return the selected Head's visible focus client, if it has an X window." + (let* ((world (x11-backend-world backend)) + (presentation (current-presentation + world (x11-backend-focused-head-id backend))) + (client-id (or (ewmh-fullscreen-client-id-for-head + backend (x11-backend-focused-head-id backend)) + (and presentation + (presentation-focus-client-id presentation))))) + (when (and client-id + (%geometry-for-client geometries client-id) + (gethash client-id (x11-backend-client-windows backend))) + client-id))) + +(defun %active-floating-client-ids (backend geometries) + "Return visible floating client ids in stable Head/placement order." + (let ((world (x11-backend-world backend)) + (client-ids '())) + (dolist (head-id (x11-backend-head-ids backend)) + (let ((presentation (current-presentation world head-id))) + (when presentation + (dolist (placement (presentation-placements presentation)) + (let ((client-id (placement-client-id placement))) + (when (and (eq (placement-kind placement) :float) + (member client-id + (presentation-leased-client-ids world presentation) + :test #'equal) + (%geometry-for-client geometries client-id)) + (push client-id client-ids))))))) + (nreverse client-ids))) + +(defun build-render-plan (backend) + "Describe the X11 effects needed to realize every configured active Head. + +The selected Head contributes the sole input-focus target. A blank selected +Head explicitly focuses the root window, keeping the focus operation defined +without inventing a global workspace or Head policy." + (multiple-value-bind (geometries borders) (%active-client-geometries backend) + (let* ((world (x11-backend-world backend)) + (effects '()) + (style (%window-appearance backend)) + (focus-client-id + (unless (x11-backend-focus-root-override-p backend) + (%focused-client-id backend geometries))) + (floating-client-ids (%active-floating-client-ids backend geometries)) + (fullscreen-client-ids (ewmh-active-fullscreen-client-ids backend))) + (dolist (client-id (%registered-client-ids backend)) + (let ((geometry (%geometry-for-client geometries client-id))) + (if geometry + (progn + (push (make-x11-effect + :kind :configure :client-id client-id :geometry geometry + :border-width (cdr (assoc client-id borders :test #'equal)) + :border-color + (if (equal client-id focus-client-id) + (window-appearance-focused-border style) + (window-appearance-unfocused-border style))) + effects) + (push (make-x11-effect :kind :map :client-id client-id) effects)) + (push (make-x11-effect :kind :unmap :client-id client-id) effects)))) + ;; Floats deliberately sit above tiled content. Raising the focused + ;; float last gives ordinary click focus the expected stacking behavior + ;; without turning z-order into hidden model state yet. + (dolist (client-id + (append + (remove-if (lambda (client-id) + (member client-id fullscreen-client-ids :test #'equal)) + floating-client-ids) + fullscreen-client-ids)) + (push (make-x11-effect :kind :raise :client-id client-id) effects)) + (push (if focus-client-id + (make-x11-effect :kind :focus :client-id focus-client-id) + (make-x11-effect :kind :focus-root)) + effects) + (make-x11-render-plan :world-revision (world-revision world) + :effects (nreverse effects))))) + +(defun %configure-window (window geometry border-width border-pixel) + (xlib:with-state (window) + (setf (xlib:drawable-x window) (geometry-x geometry) + (xlib:drawable-y window) (geometry-y geometry) + (xlib:drawable-width window) (max 1 (geometry-width geometry)) + (xlib:drawable-height window) (max 1 (geometry-height geometry)) + (xlib:drawable-border-width window) border-width) + (when border-pixel + (setf (xlib:window-border window) border-pixel)))) + +(defun %execute-x11-effect (backend effect) + (let* ((client-id (x11-effect-client-id effect)) + (window (and client-id + (gethash client-id (x11-backend-client-windows backend))))) + (ecase (x11-effect-kind effect) + (:configure + (when window + (%remember-client-border backend client-id window) + (%configure-window window (x11-effect-geometry effect) + (x11-effect-border-width effect) + (and (x11-effect-border-color effect) + (%border-pixel backend (x11-effect-border-color effect)))))) + (:map + (when window + ;; WM_STATE is part of the visible-client transition itself, not a + ;; speculative model field. The ICCCM cache makes repeated render + ;; plans cheap while adoption and reappearance still publish NORMAL. + (unless (eq (let ((info (backend-client-icccm-info backend client-id))) + (and info (icccm-client-info-wm-state info))) + :normal) + (icccm-set-client-state backend client-id window :normal) + (xlib:map-window window)))) + (:unmap + (when window + ;; Remember this before the request: root-level UnmapNotify is also + ;; how an application tells us it withdrew. The lifecycle layer + ;; consumes exactly one token instead of mistaking View hiding for a + ;; destroyed task client. + (unless (eq (let ((info (backend-client-icccm-info backend client-id))) + (and info (icccm-client-info-wm-state info))) + :iconic) + (%note-pending-unmap backend window) + (icccm-set-client-state backend client-id window :iconic) + (xlib:unmap-window window)))) + (:raise + (when window + (setf (xlib:window-priority window) :above))) + (:focus + (when window + (icccm-focus-client backend client-id window) + (ewmh-set-active-window backend client-id) + (%attention-acknowledge-client backend client-id))) + (:focus-root + (xlib:set-input-focus (x11-backend-display backend) + (x11-backend-root backend) + :pointer-root) + (ewmh-set-active-window backend nil))))) + +(defun execute-render-plan (backend plan) + "Execute a current X11-RENDER-PLAN and flush it as one CLX batch." + (unless (= (x11-render-plan-world-revision plan) + (world-revision (x11-backend-world backend))) + (error 'invalid-transition + :description "Refusing to execute a stale X11 render plan.")) + (dolist (effect (x11-render-plan-effects plan)) + (%execute-x11-effect backend effect)) + ;; Rendering can raise floats/fullscreen clients, so publish the resulting + ;; root-child stacking order only after all visual effects have been issued. + (ewmh-sync-client-lists backend) + (xlib:display-force-output (x11-backend-display backend)) + backend) + +(defun %floating-client-configure-effect (backend presentation client-id) + "Resolve one leased float using the same layout, borders, and hints as a full pass. + +No mapping, restacking, focus, or root-property effects are implied. A hidden +or unavailable client is left alone; fullscreen keeps its physical-Head size +while the underlying float rectangle can still be edited for later restoration." + (let* ((head-id (presentation-head-id presentation)) + (world (x11-backend-world backend))) + (when (and (presentation-client-floating-p presentation client-id) + (member client-id (presentation-leased-client-ids world presentation) + :test #'equal) + (not (equal client-id (ewmh-fullscreen-client-id-for-head backend head-id)))) + (let* ((area (x11-head-work-area backend head-id)) + (geometry (%geometry-for-client + (resolve-presentation-layout + presentation (x11-work-area-width area) (x11-work-area-height area) + :x (x11-work-area-x area) :y (x11-work-area-y area)) + client-id))) + (when geometry + (multiple-value-bind (content border) + (%styled-client-geometry backend client-id geometry area nil) + (make-x11-effect :kind :configure :client-id client-id + :geometry content :border-width border))))))) + +(defun apply-floating-client-geometry (backend presentation client-id) + "Flush a geometry-only update without synchronous X queries or a full repaint." + (let ((effect (%floating-client-configure-effect backend presentation client-id))) + (when effect (%execute-x11-effect backend effect))) + (when (x11-backend-display backend) + (xlib:display-force-output (x11-backend-display backend))) + backend) + +(declaim (ftype function %navigation-state)) + +(defun apply-active-presentation (backend) + "Build and execute the current X11 reconciliation plan. + +This compatibility entry point remains convenient for small callers; new +frontends may inspect BUILD-RENDER-PLAN before explicitly executing it. The +Head bar is adapter UI, so it is redrawn afterward rather than becoming a +model effect." + (%navigation-state backend) + (execute-render-plan backend (build-render-plan backend)) + (render-head-bars backend)) diff --git a/src/x11/resilience.lisp b/src/x11/resilience.lisp new file mode 100644 index 0000000..0865467 --- /dev/null +++ b/src/x11/resilience.lisp @@ -0,0 +1,154 @@ +(in-package #:lime.x11) + +;;;; X11 race policy, bounded diagnostics, and explicit recovery primitives. +;;;; No automatic retry of arbitrary model mutations and no persistence here. + +(define-condition x11-client-disappeared (error) + ((window-id :initarg :window-id :reader disappeared-window-id)) + (:report (lambda (condition stream) + (format stream "X11 client #x~X disappeared during a query." + (disappeared-window-id condition))))) + +(defun %diagnostic-condition-message (condition) + ;; A broken user condition printer must not turn recovery into a new fault. + (handler-case + (let ((*print-length* 12) (*print-level* 4) (*print-circle* t)) + (let ((message (princ-to-string condition))) + (subseq message 0 (min 4096 (length message))))) + (error () "[Condition could not be printed]"))) + +(defun backend-record-diagnostic (backend condition &key (source :event-loop) backtrace) + "Retain at most 32 reports, newest first; never print whole model/window objects." + (let ((report (list :time (get-universal-time) :source source + :event (copy-list (x11-backend-event-context backend)) + :condition-type (type-of condition) + :message (%diagnostic-condition-message condition) + :backtrace backtrace))) + (push report (x11-backend-diagnostics backend)) + (when (> (length (x11-backend-diagnostics backend)) 32) + (setf (cdr (nthcdr 31 (x11-backend-diagnostics backend))) nil)) + report)) + +(defun backend-diagnostics (backend) + "Return copied reports plus the count of harmless X11 timing races." + (list :expected-x-errors (x11-backend-expected-x-error-count backend) + :reports (copy-tree (x11-backend-diagnostics backend)))) + +(defun %external-resource-p (backend display resource-id) + "Exclude the root and Lime-owned UI/resources from destroyed-client policy." + (and (integerp resource-id) (plusp resource-id) + (/= resource-id (xlib:window-id (x11-backend-root backend))) + (/= (logand resource-id (lognot (xlib:display-resource-id-mask display))) + (xlib:display-resource-id-base display)))) + +(defun %expected-x-error-policy (error-key major asynchronous external-p) + "Return :IGNORE, :CLIENT-GONE, or NIL for a specific protocol failure. + +Never suppress BadAccess (root ownership/grabs), BadValue, or faults in our UI. +Synchronous queries must abort: ignoring their error would wait for no reply." + (cond + ((and asynchronous (eq error-key 'xlib:match-error) (= major 42)) :ignore) + ((and external-p + (or (and (eq error-key 'xlib:window-error) + (member major '(2 3 8 10 12 15 18 19 20 25 28 29 38 42))) + (and (eq error-key 'xlib:drawable-error) (= major 14)))) + (if asynchronous :ignore :client-gone)))) + +(defun %handle-display-error (backend display error-key &rest arguments + &key asynchronous resource-id (major 0) &allow-other-keys) + (let ((policy (%expected-x-error-policy + error-key major asynchronous + (%external-resource-p backend display resource-id)))) + (case policy + (:ignore (incf (x11-backend-expected-x-error-count backend)) nil) + (:client-gone + (incf (x11-backend-expected-x-error-count backend)) + (error 'x11-client-disappeared :window-id resource-id)) + (otherwise (apply #'xlib:default-error-handler display error-key arguments))))) + +(defun %forget-disappeared-client (backend window-id) + (let* ((client-id (gethash window-id (x11-backend-window-clients backend))) + (window (and client-id (gethash client-id (x11-backend-client-windows backend))))) + (when window + (%forget-window backend window) + (%forget-pending-unmaps backend window) + (%retire-managed-client backend client-id :window-id window-id)) + (let ((external (gethash window-id (x11-backend-ewmh-external-windows backend)))) + (when external (ewmh-forget-external-window backend external))))) + +(defun %call-with-client-race-handling (backend function) + "Abandon a failed client query at an event/adoption boundary, not the session." + (handler-case (funcall function) + (x11-client-disappeared (condition) + (%forget-disappeared-client backend (disappeared-window-id condition)) + (apply-active-presentation backend) + nil))) + +(defun %call-with-cleanup-diagnostics (backend function) + (handler-case (funcall function) + (error (condition) + (backend-record-diagnostic backend condition :source :cleanup) + nil))) + +(defun backend-release-input (backend) + "Release Lime's active grabs independently, even if its overlay is broken." + (setf (x11-backend-pointer-drag backend) nil) + (let ((display (x11-backend-display backend))) + (when display + (dolist (function (list (lambda () (xlib:allow-events display :async-both)) + (lambda () (xlib:ungrab-pointer display)) + (lambda () (xlib:ungrab-keyboard display)) + (lambda () (backend-close-command-palette backend :acknowledge-p nil)) + (lambda () (xlib:display-force-output display)))) + (%call-with-cleanup-diagnostics backend function)))) + backend) + +(defun %validate-client-registrations (backend) + "Do not resume a valid core world whose adapter mappings are half-mutated." + (let ((world (x11-backend-world backend)) + (windows (x11-backend-client-windows backend)) + (clients (x11-backend-window-clients backend))) + (dolist (activity (list-activities world)) + (dolist (id (activity-client-ids activity)) + (unless (gethash id windows) + (error "Client ~S has no X11 window registration; repair or restart before resuming." id)))) + (maphash (lambda (id window) + (find-client world id) + (unless (equal id (gethash (xlib:window-id window) clients)) + (error "Inconsistent X11 registration for client ~S." id))) + windows) + (maphash (lambda (window-id id) + (let ((window (gethash id windows))) + (unless (and window (= window-id (xlib:window-id window))) + (error "Inconsistent X11 registration for window ~S." window-id)))) + clients)) + t) + +(defun backend-reconcile-after-error (backend) + "Validate the retained world, retire vanished clients, and render before resuming. + +This is an explicit recovery attempt, not a rollback or a fresh empty world. +An invalid model, disconnected server, or still-broken renderer keeps recovery +from succeeding. Queued lifecycle/input events are not blindly discarded." + (unless (x11-backend-display backend) + (error "The X connection is closed; restart Lime instead of resuming it.")) + (validate-world (x11-backend-world backend)) + (let* ((children (xlib:query-tree (x11-backend-root backend))) + (live-ids (mapcar #'xlib:window-id children)) + (gone '())) + (maphash (lambda (window-id client-id) + (declare (ignore client-id)) + (unless (member window-id live-ids) (push window-id gone))) + (x11-backend-window-clients backend)) + (dolist (window-id gone) (%forget-disappeared-client backend window-id)) + ;; Complete an interrupted adoption only when that was the failed event. + (let* ((event (x11-backend-event-context backend)) + (window (and (eq :map-request (getf event :kind)) + (find (getf event :window-id) children :key #'xlib:window-id)))) + (when window + (%call-with-client-race-handling backend (lambda () (manage-window backend window)))))) + (validate-world (x11-backend-world backend)) + (%validate-client-registrations backend) + (apply-active-presentation backend) + (xlib:display-finish-output (x11-backend-display backend)) + backend) diff --git a/src/x11/session-settings.lisp b/src/x11/session-settings.lisp new file mode 100644 index 0000000..bfda6c4 --- /dev/null +++ b/src/x11/session-settings.lisp @@ -0,0 +1,239 @@ +(in-package #:lime.x11) + +;;;; Display-local settings for applications, not cursor rendering or model state. +;;;; No GTK config files, dconf, process-global environment, or D-Bus activation +;;;; environment are changed. All X operations run on the backend owner thread. + +(defstruct cursor-session-settings + theme size window selection (serial 0) + resources-before resources-last resources-owned-p + (manager-status :following-system)) + +(defvar *cursor-session-settings* (make-hash-table :test #'eq)) + +(defun %cursor-settings-window-equal (one two) + (or (eq one two) (and one two (xlib:window-equal one two)))) + +(defun %xsettings-cursor-bytes (theme size serial) + "Encode the two optional cursor settings, using explicit little-endian bytes." + (let ((bytes (make-array 0 :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0))) + (labels ((number (value count) + (dotimes (i count) (vector-push-extend (ldb (byte 8 (* i 8)) value) bytes))) + (text (value length-size) + (let ((utf8 (babel:string-to-octets value :encoding :utf-8))) + (number (length utf8) length-size) + (map nil (lambda (byte) (vector-push-extend byte bytes)) utf8))) + (pad () (loop until (zerop (mod (length bytes) 4)) do (number 0 1))) + (header (type name) + (number type 1) (number 0 1) (text name 2) (pad) (number serial 4))) + (number 0 4) ; LSBFirst plus three padding bytes. + (number serial 4) + (number (+ (if theme 1 0) (if size 1 0)) 4) + (when theme (header 1 "Gtk/CursorThemeName") (text theme 4) (pad)) + (when size (header 0 "Gtk/CursorThemeSize") (number size 4))) + bytes)) + +(defun %cursor-resource-records (text) + "Keep physical text intact, grouping backslash-continued resource records." + (let ((start 0) (records nil)) + (loop for end below (length text) + when (and (char= (char text end) #\Newline) + (evenp (loop for i downfrom (1- end) to start + while (char= (char text i) #\\) count t))) + do (push (subseq text start (1+ end)) records) (setf start (1+ end))) + (when (< start (length text)) (push (subseq text start) records)) + (nreverse records))) + +(defun %cursor-resource-key (record) + (let* ((colon (position #\: record)) + (key (and colon (string-trim '(#\Space #\Tab) (subseq record 0 colon))))) + (find key '("Xcursor.theme" "Xcursor.size") :test #'equal))) + +(defun %cursor-resource-entries (text key) + (remove-if-not (lambda (record) (equal key (%cursor-resource-key record))) + (%cursor-resource-records (or text "")))) + +(defun %replace-cursor-resource (text key records) + (let ((remaining (format nil "~{~A~}" + (remove-if (lambda (record) (equal key (%cursor-resource-key record))) + (%cursor-resource-records (or text "")))))) + (if (null records) remaining + (format nil "~A~A~{~A~}" remaining + (if (or (zerop (length remaining)) (char= (char remaining (1- (length remaining))) #\Newline)) + "" (string #\Newline)) records)))) + +(defun %unpublished-cursor-resources (state current) + "Undo only our own entries; concurrent changes to any other resource survive." + (if (not (and state (cursor-session-settings-resources-owned-p state))) current + (let ((before (cursor-session-settings-resources-before state)) + (last (cursor-session-settings-resources-last state))) + (if (equal current last) before + (let ((result current)) + (dolist (key '("Xcursor.theme" "Xcursor.size") result) + (let ((ours (%cursor-resource-entries last key))) + (when (and ours (equal ours (%cursor-resource-entries current key))) + (setf result (%replace-cursor-resource + result key (%cursor-resource-entries before key))))))))))) + +(defun %read-session-resources (root) + (multiple-value-bind (bytes type format) (xlib:get-property root :RESOURCE_MANAGER) + (when type + (unless (and (eq type :STRING) (= format 8)) + (error "RESOURCE_MANAGER is not a STRING/8 property; refusing to overwrite it.")) + (map 'string #'code-char bytes)))) + +(defun %write-session-resources (root text) + (if text + (xlib:change-property root :RESOURCE_MANAGER (map 'vector #'char-code text) :STRING 8) + (xlib:delete-property root :RESOURCE_MANAGER))) + +(defun %cursor-system-resources (backend) + "Resolve defaults without feeding our last publication back into NIL config." + (let ((database (xlib:make-resource-database)) + (text (%unpublished-cursor-resources + (gethash backend *cursor-session-settings*) + (%read-session-resources (x11-backend-root backend))))) + (when text + (with-input-from-string (in text) (xlib:read-resources database in))) + database)) + +(defun %cursor-resource-value (theme) + ;; STRING/8 properties contain bytes, while XSETTINGS explicitly uses UTF-8. + (with-output-to-string (out) + (loop for byte across (babel:string-to-octets theme :encoding :utf-8) + do (when (= byte 92) (write-char #\\ out)) (write-char (code-char byte) out)))) + +(defun %publish-cursor-resources (backend state theme size) + (let ((display (x11-backend-display backend)) (root (x11-backend-root backend))) + (xlib:with-server-grabbed (display) + (let* ((current (%read-session-resources root)) + (before (%unpublished-cursor-resources state current)) + (next before)) + (when theme + (setf next (%replace-cursor-resource next "Xcursor.theme" + (list (format nil "Xcursor.theme: ~A~%" (%cursor-resource-value theme)))))) + (when size + (setf next (%replace-cursor-resource next "Xcursor.size" + (list (format nil "Xcursor.size: ~D~%" size))))) + ;; Record ownership before the request, so a later X error is reversible. + (setf (cursor-session-settings-resources-before state) before + (cursor-session-settings-resources-last state) next + (cursor-session-settings-resources-owned-p state) (or theme size)) + (unless (equal current next) (%write-session-resources root next)))) + (xlib:display-force-output display))) + +(defun %destroy-cursor-settings-window (state) + (when (cursor-session-settings-window state) + ;; Destroying our window releases only our ownership, never a successor's. + (xlib:destroy-window (cursor-session-settings-window state)) + (setf (cursor-session-settings-window state) nil))) + +(defun %cursor-settings-timestamp (display window) + (xlib:change-property window :_LIME_SETTINGS_TIME #(0) :INTEGER 8) + ;; Preserve unrelated queued input/MapRequests. Only our timestamp is consumed. + (or (xlib:event-case (display :timeout 2 :discard-p nil :force-output-p t) + (:property-notify ((:window event-window) atom time) + (when (and (%cursor-settings-window-equal window event-window) (eq atom :_LIME_SETTINGS_TIME)) time))) + (error "Timed out obtaining an XSETTINGS ownership timestamp."))) + +(defun %publish-cursor-xsettings (backend state theme size) + (let* ((display (x11-backend-display backend)) + (root (x11-backend-root backend)) + (selection (or (cursor-session-settings-selection state) + (setf (cursor-session-settings-selection state) + (intern (format nil "_XSETTINGS_S~D" + (position (x11-backend-x-screen backend) + (xlib:display-roots display))) :keyword))))) + (cond + ((not (or theme size)) + (%destroy-cursor-settings-window state) + (setf (cursor-session-settings-manager-status state) :following-system)) + (t + (let ((owner (xlib:selection-owner display selection))) + (unless (%cursor-settings-window-equal owner (cursor-session-settings-window state)) + (%destroy-cursor-settings-window state)) + (if (and owner (not (%cursor-settings-window-equal owner (cursor-session-settings-window state)))) + (setf (cursor-session-settings-manager-status state) :external-manager) + (progn + (unless (cursor-session-settings-window state) + (let* ((window (xlib:create-window :parent root :x -1 :y -1 :width 1 :height 1 + :override-redirect :on :event-mask '(:property-change))) + (claimed nil)) + (unwind-protect + (let ((time (%cursor-settings-timestamp display window))) + (xlib:with-server-grabbed (display) + (unless (xlib:selection-owner display selection) + (setf (xlib:selection-owner display selection time) window) + (when (%cursor-settings-window-equal window (xlib:selection-owner display selection)) + (setf claimed t (cursor-session-settings-window state) window) + ;; A client responding to MANAGER must never see + ;; an owner without its initial settings property. + (xlib:change-property + window :_XSETTINGS_SETTINGS + (%xsettings-cursor-bytes theme size + (ldb (byte 32 0) (1+ (cursor-session-settings-serial state)))) + :_XSETTINGS_SETTINGS 8) + (xlib:send-event root :client-message '(:structure-notify) + :window root :type :MANAGER :format 32 + :data (vector time (xlib:intern-atom display selection) + (xlib:window-id window) 0 0)))))) + (unless claimed (xlib:destroy-window window))))) + (if (cursor-session-settings-window state) + (progn + (setf (cursor-session-settings-serial state) + (ldb (byte 32 0) (1+ (cursor-session-settings-serial state)))) + (xlib:change-property + (cursor-session-settings-window state) :_XSETTINGS_SETTINGS + (%xsettings-cursor-bytes theme size (cursor-session-settings-serial state)) + :_XSETTINGS_SETTINGS 8) + (setf (cursor-session-settings-manager-status state) :published)) + (setf (cursor-session-settings-manager-status state) :external-manager))))))) + (xlib:display-force-output display))) + +(defun %apply-cursor-session-settings (backend style) + (%validate-ui-cursor-style style) + (when (x11-backend-display backend) + (let* ((theme (ui-cursor-style-theme style)) + (size (unless (eq theme :core) (ui-cursor-style-size style))) + (theme (and (stringp theme) theme)) + (state (or (gethash backend *cursor-session-settings*) + (setf (gethash backend *cursor-session-settings*) (make-cursor-session-settings))))) + (%publish-cursor-resources backend state theme size) + (%publish-cursor-xsettings backend state theme size) + (xlib:display-finish-output (x11-backend-display backend)) + (setf (cursor-session-settings-theme state) theme + (cursor-session-settings-size state) size)))) + +(defun %handle-cursor-settings-selection-clear (backend window selection) + (let ((state (gethash backend *cursor-session-settings*))) + (when (and state (eq selection (cursor-session-settings-selection state)) + (%cursor-settings-window-equal window (cursor-session-settings-window state))) + (%destroy-cursor-settings-window state) + (setf (cursor-session-settings-manager-status state) :external-manager) + t))) + +(defun %shutdown-cursor-session-settings (backend) + (let ((state (gethash backend *cursor-session-settings*))) + (when state + (unwind-protect (%publish-cursor-resources backend state nil nil) + (%destroy-cursor-settings-window state) + (remhash backend *cursor-session-settings*))))) + +(defun %cursor-session-report (backend) + (let ((state (gethash backend *cursor-session-settings*))) + (if state (list :xsettings (cursor-session-settings-manager-status state) + :theme (cursor-session-settings-theme state) :size (cursor-session-settings-size state) + :xresources (not (null (cursor-session-settings-resources-owned-p state)))) + (list :xsettings :following-system)))) + +(defun %cursor-session-launch-argv (backend argv) + "Overlay only the child's environment; never change the Lisp process or D-Bus." + (let* ((state (gethash backend *cursor-session-settings*)) + (theme (and state (cursor-session-settings-theme state))) + (size (and state (cursor-session-settings-size state)))) + (if (or theme size) + (append (list "env") + (when theme (list (format nil "XCURSOR_THEME=~A" theme))) + (when size (list (format nil "XCURSOR_SIZE=~D" size))) argv) + argv))) diff --git a/src/x11/status-desktop.lisp b/src/x11/status-desktop.lisp new file mode 100644 index 0000000..93da1c6 --- /dev/null +++ b/src/x11/status-desktop.lisp @@ -0,0 +1,265 @@ +(in-package #:lime.x11) + +;;;; Optional desktop sources. All blocking I/O belongs to managed workers. +;;;; MPD uses its native protocol; playerctl/pactl are event bridges, not polls. + +(defmacro %with-status-query-timeout (&body body) + #+sbcl `(sb-ext:with-timeout 3 ,@body) + #-sbcl (declare (ignore body)) + #-sbcl `(error "Desktop status I/O currently requires SBCL.")) + +(defun %status-read-line (stream &optional (limit 16384)) + "Bound external line sizes, including peers that never send a newline." + (with-output-to-string (out) + (loop for count from 0 + for char = (read-char stream nil nil) + do (unless char (error "Status source disconnected.")) + (when (char= char #\Newline) (return)) + (when (>= count limit) (error "Status source line exceeds ~D characters." limit)) + (unless (char= char #\Return) (write-char char out))))) + +(defun %call-with-status-process (worker argv function) + (let ((process (uiop:launch-program (append '("env" "LC_ALL=C.UTF-8") argv) + :input nil :output :stream :error-output nil + :external-format :utf-8))) + (unwind-protect + (%call-with-status-resource + worker (lambda () (uiop:terminate-process process :urgent t)) + (lambda () (funcall function (uiop:process-info-output process) process))) + ;; Reap only our own helper; no shells, killall, or global daemon changes. + (ignore-errors (uiop:terminate-process process :urgent t)) + (ignore-errors (uiop:wait-process process)) + (ignore-errors (close (uiop:process-info-output process)))))) + +(defun %status-query (worker argv) + (%call-with-status-process + worker argv + (lambda (stream process) + ;; Bound one-shot helpers without a watchdog polling thread. Subscription + ;; reads deliberately have no timeout. Lime's developer target is SBCL. + (%with-status-query-timeout + (let ((line (%status-read-line stream))) + (unless (zerop (uiop:wait-process process)) (error "Status query failed: ~A" (first argv))) + line))))) + +(defun %wall-time () + #+sbcl (multiple-value-bind (seconds microseconds) (sb-ext:get-time-of-day) + (+ 2208988800 seconds (/ microseconds 1000000d0))) + #-sbcl (get-universal-time)) + +(defun %next-minute-delay (time) + (- 60 (mod time 60))) + +(defun %clock-snapshot (time) + (multiple-value-bind (second minute hour day month year weekday daylight-p timezone) + (decode-universal-time (floor time)) + (declare (ignore second)) + (list :universal-time (floor time) :minute minute :hour hour :day day + :month month :year year :weekday weekday :daylight-p daylight-p :timezone timezone))) + +(defun make-clock-status-provider (&key (id :clock) (formatter #'format-clock-status) + foreground click-action maximum-width) + "Local date/time, freshly aligned to the next wall-clock minute after each wake." + (make-status-provider + :id id :formatter formatter :foreground foreground :maximum-width maximum-width :click-action click-action + :run (lambda (worker) + (loop until (status-cancelled-p worker) + do (status-publish worker (%clock-snapshot (%wall-time))) + (unless (status-wait worker (%next-minute-delay (%wall-time))) (return)))))) + +(defun %volume-percent (line) + ;; pactl's first channel, matching the user's old bar; never confuse raw + ;; PulseAudio units or dB with the percentage. Keep legitimate >100% values. + (let ((end (position #\% line))) + (unless end (error "No percentage in audio volume response.")) + (let ((start end)) + (loop while (and (plusp start) (digit-char-p (char line (1- start)))) do (decf start)) + (or (parse-integer line :start start :end end :junk-allowed t) + (error "Malformed audio volume percentage."))))) + +(defun %volume-event-p (line) + ;; Client connect/disconnect events from our own queries MUST NOT refresh. + (or (search " on sink #" line) (search " on server #" line) (search " on card #" line))) + +(defun %volume-snapshot (worker) + (let* ((sink (%status-query worker '("pactl" "get-default-sink"))) + (mute (%status-query worker (list "pactl" "get-sink-mute" sink))) + (volume (%status-query worker (list "pactl" "get-sink-volume" sink)))) + (unless (member mute '("Mute: yes" "Mute: no") :test #'string=) + (error "Unrecognized audio mute response.")) + (list :volume (%volume-percent volume) :muted-p (string= mute "Mute: yes") :sink sink))) + +(defun %run-volume-status (worker &key (subscribe #'%call-with-status-process) (snapshot #'%volume-snapshot)) + (funcall subscribe + worker '("pactl" "subscribe") + (lambda (stream process) + (declare (ignore process)) + ;; Subscribe before taking the initial snapshot. Events received + ;; during queries remain buffered and trigger another snapshot. + (status-publish worker (funcall snapshot worker)) + (loop until (status-cancelled-p worker) + for line = (%status-read-line stream) + do (let ((dirty (%volume-event-p line))) + ;; Collapse bursts already queued during a query. No + ;; debounce timer delaying the first visible update. + (loop while (listen stream) + do (when (%volume-event-p (%status-read-line stream)) (setf dirty t))) + (when dirty (status-publish worker (funcall snapshot worker)))))))) + +(defun make-volume-status-provider (&key (id :volume) (formatter #'format-volume-status) + foreground maximum-width + (click-action + (lambda (backend head-id) + (declare (ignore head-id)) + (backend-launch-program backend '("pactl" "set-sink-mute" "@DEFAULT_SINK@" "toggle"))))) + "Subscribe to PulseAudio/PipeWire-Pulse events; clicking toggles sink mute." + (make-status-provider + :id id :formatter formatter :foreground foreground :maximum-width maximum-width :click-action click-action + :run #'%run-volume-status)) + +(defstruct (music-status-provider (:include status-provider) + (:constructor %make-music-status-provider)) + source sources host port password) + +(defun %music-snapshot (state title source) + (list :state (cond ((member state '("play" "Playing") :test #'string=) :playing) + ((member state '("pause" "Paused") :test #'string=) :paused) + ((member state '("stop" "Stopped") :test #'string=) :stopped) + (t :unknown)) + :title title :source source)) + +(defun %mpd-quote (value) + (with-output-to-string (out) + (write-char #\" out) + (loop for char across value do + (when (member char '(#\Newline #\Return)) (error "Newline in MPD argument.")) + (when (member char '(#\\ #\")) (write-char #\\ out)) + (write-char char out)) + (write-char #\" out))) + +(defun %mpd-send (stream command) + (let ((bytes (babel:string-to-octets (concatenate 'string command (string #\Newline)) :encoding :utf-8))) + (write-sequence bytes stream) (force-output stream))) + +(defun %mpd-line (stream) + (let ((bytes (make-array 128 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) + (loop for byte = (read-byte stream) + until (= byte 10) + do (when (>= (length bytes) 65536) (error "Oversized MPD response.")) + (vector-push-extend byte bytes)) + (babel:octets-to-string bytes :encoding :utf-8))) + +(defun %mpd-response (stream) + (loop for count below 1024 for line = (%mpd-line stream) + when (string= line "OK") return pairs + when (uiop:string-prefix-p "ACK " line) do (error "MPD rejected status request.") + collect (let ((separator (search ": " line))) + (if separator (cons (subseq line 0 separator) (subseq line (+ separator 2))) + (cons line ""))) into pairs + finally (error "Too many MPD response fields."))) + +(defun %run-mpd-status (worker provider) + (let* ((socket (usocket:socket-connect (music-status-provider-host provider) + (music-status-provider-port provider) + :element-type '(unsigned-byte 8) + :timeout 3 :read-timeout nil)) + (stream (usocket:socket-stream socket))) + (unwind-protect + (%call-with-status-resource + worker (lambda () (usocket:socket-shutdown socket :io)) + (lambda () + (%with-status-query-timeout + (unless (uiop:string-prefix-p "OK MPD " (%mpd-line stream)) + (error "Not an MPD server.")) + (when (music-status-provider-password provider) + (%mpd-send stream (concatenate 'string "password " (%mpd-quote (music-status-provider-password provider)))) + (%mpd-response stream))) + (loop until (status-cancelled-p worker) + do (%with-status-query-timeout + (%mpd-send stream "status") + (let ((status (%mpd-response stream))) + (%mpd-send stream "currentsong") + (let* ((song (%mpd-response stream)) + (title (or (cdr (assoc "Title" song :test #'string=)) + (let ((file (cdr (assoc "file" song :test #'string=)))) + (and file (pathname-name file)))))) + (status-publish worker (%music-snapshot (cdr (assoc "state" status :test #'string=)) + title :mpd))))) + ;; The SAME connection accumulates changes between the + ;; snapshot and IDLE, eliminating a subscribe/query gap. + (%mpd-send stream "idle player playlist") + (%mpd-response stream)))) + (ignore-errors (usocket:socket-close socket))))) + +(defun %mpris-line-snapshot (line source) + (let ((separator (position #\Tab line))) + (when separator (%music-snapshot (subseq line 0 separator) (subseq line (1+ separator)) source)))) + +(defun %run-mpris-status (worker provider) + (%call-with-status-process + worker (list "playerctl" "--player" (music-status-provider-source provider) + "--follow" "metadata" "--format" (format nil "{{status}}~C{{title}}" #\Tab)) + (lambda (stream process) + (declare (ignore process)) + (loop until (status-cancelled-p worker) + do (status-publish worker (%mpris-line-snapshot (%status-read-line stream) + (music-status-provider-source provider))))))) + +(defun make-music-status-provider (&key (id :music) (source :mpd) (sources '(:mpd "spotify")) + (mpd-host "127.0.0.1") (mpd-port 6600) mpd-password + (maximum-width 320) (formatter #'format-music-status) foreground + (click-action nil click-action-supplied-p)) + "SOURCE is :MPD or a playerctl player name. Source selection and media controls +share this object, rather than scraping or rewriting another bar's script." + (unless (and (listp sources) (member source sources :test #'equal) + (every (lambda (value) (or (eq value :mpd) (and (stringp value) (plusp (length value))))) sources) + (stringp mpd-host) (integerp mpd-port) (<= 1 mpd-port 65535) + (or (null mpd-password) (stringp mpd-password)) + (integerp maximum-width) (plusp maximum-width)) + (error "Invalid music status source configuration.")) + (let ((provider (%make-music-status-provider :id id :source source :sources (copy-list sources) + :host mpd-host :port mpd-port :password mpd-password + :maximum-width maximum-width :formatter formatter :foreground foreground))) + (setf (status-provider-run provider) + (lambda (worker) + (if (eq (music-status-provider-source provider) :mpd) + (%run-mpd-status worker provider) (%run-mpris-status worker provider))) + (status-provider-click-action provider) + (if click-action-supplied-p click-action (lambda (backend head-id) + (declare (ignore head-id)) + (backend-music-command backend :toggle :id id)))) + provider)) + +(defun %backend-music-provider (backend id) + (or (find-if (lambda (provider) (and (typep provider 'music-status-provider) + (equal id (status-provider-id provider)))) + (x11-backend-head-bar-status-providers backend)) + (error 'invalid-transition :description "No matching music status provider is configured."))) + +(defun backend-cycle-music-source (backend &key (id :music)) + (let* ((provider (%backend-music-provider backend id)) + (runtime (x11-backend-status-runtime backend)) + (worker (find provider (status-runtime-workers runtime) :key #'status-worker-provider))) + (%stop-status-worker worker) + (setf (music-status-provider-source provider) + (or (second (member (music-status-provider-source provider) + (music-status-provider-sources provider) :test #'equal)) + (first (music-status-provider-sources provider))) + (status-runtime-workers runtime) + (substitute (%start-status-worker runtime provider) worker (status-runtime-workers runtime))) + (render-head-bars backend) + (music-status-provider-source provider))) + +(defun %music-command-argv (provider command) + (let* ((source (music-status-provider-source provider)) + (verb (ecase command (:toggle "toggle") (:next "next") (:previous "prev")))) + (if (eq source :mpd) + (list "mpc" "--host" (if (music-status-provider-password provider) + (format nil "~A@~A" (music-status-provider-password provider) (music-status-provider-host provider)) + (music-status-provider-host provider)) + "--port" (write-to-string (music-status-provider-port provider)) verb) + (list "playerctl" "--player" source + (ecase command (:toggle "play-pause") (:next "next") (:previous "previous")))))) + +(defun backend-music-command (backend command &key (id :music)) + (backend-launch-program backend (%music-command-argv (%backend-music-provider backend id) command))) diff --git a/src/x11/status-format.lisp b/src/x11/status-format.lisp new file mode 100644 index 0000000..2bf93ee --- /dev/null +++ b/src/x11/status-format.lisp @@ -0,0 +1,41 @@ +(in-package #:lime.x11) + +;;;; Optional presentation helpers, independent of subscriptions and commands. +;;;; Configurations may parameterize these or supply entirely different Lisp +;;;; formatters. Text remains plain text, never executable color/icon markup. + +(defun %status-icon-label (icon label gap &optional icon-foreground) + (if (or (null icon) (equal icon "")) label + (let ((text (format nil "~A~A~A" icon gap label))) + (if icon-foreground + (%validate-head-bar-segment + (make-head-bar-segment :text text :prefix-length (length icon) + :prefix-foreground icon-foreground)) + text)))) + +(defun format-music-status (data &key (playing-icon "") (paused-icon "") + (icon-gap " ") (untitled "Untitled track") icon-foreground) + "Format a music snapshot; stopped/unknown playback is hidden by this helper." + (when (member (getf data :state) '(:playing :paused)) + (let ((title (getf data :title))) + (%status-icon-label (if (eq (getf data :state) :playing) playing-icon paused-icon) + (if (and title (plusp (length title))) title untitled) icon-gap icon-foreground)))) + +(defun format-volume-status (data &key (icon "") (muted-icon "") + (icon-gap " ") (muted-label "Muted") icon-foreground) + "Format a volume snapshot; mute and channel volume remain independent data." + (if (getf data :muted-p) + (%status-icon-label muted-icon muted-label icon-gap icon-foreground) + (%status-icon-label icon (format nil "~D%" (getf data :volume)) icon-gap icon-foreground))) + +(defun format-clock-status (data &key (icon "") (icon-gap " ") twenty-four-hour-p icon-foreground) + "Format local date/time data. Supply a custom formatter for other date styles." + (let ((hour (getf data :hour))) + (%status-icon-label + icon + (format nil "~A ~A ~2,'0D, ~2,'0D:~2,'0D" + (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") (getf data :weekday)) + (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + (1- (getf data :month))) + (getf data :day) (if twenty-four-hour-p hour (1+ (mod (1- hour) 12))) (getf data :minute)) + icon-gap icon-foreground))) diff --git a/src/x11/status.lisp b/src/x11/status.lisp new file mode 100644 index 0000000..72f4e77 --- /dev/null +++ b/src/x11/status.lisp @@ -0,0 +1,234 @@ +(in-package #:lime.x11) + +;;;; Managed, event-driven status sources. No worker touches the WM connection, +;;;; the world, or the renderer. A separate, serialized notification connection +;;;; sends one coalesced event to wake even a completely idle X event loop. + +(defstruct status-provider + "RUN publishes data with STATUS-PUBLISH and waits for source events. +FORMATTER receives a copy of cached data on the X thread and returns a string, +HEAD-BAR-SEGMENT, or NIL. It performs no I/O. CLICK-ACTION also runs on the X +thread with (BACKEND HEAD-ID). Plain string-publishing providers still work." + id run (formatter #'identity) click-action maximum-width foreground) + +(defstruct status-worker + provider runtime thread + (lock (bt:make-lock "Lime status worker")) + (condition (bt:make-condition-variable)) + cancelled-p value error + (cancel-functions '())) + +(defstruct status-runtime + window display target + (lock (bt:make-lock "Lime status notification")) + dirty-p closed-p + (workers '())) + +(defun %validate-status-providers (providers) + (unless (and (listp providers) + (every (lambda (provider) + (or (functionp provider) + (and (typep provider 'status-provider) + (status-provider-id provider) + (functionp (status-provider-run provider)) + (functionp (status-provider-formatter provider)) + (or (null (status-provider-foreground provider)) + (%bar-color-p (status-provider-foreground provider))) + (or (null (status-provider-maximum-width provider)) + (and (integerp (status-provider-maximum-width provider)) + (plusp (status-provider-maximum-width provider)))) + (or (null (status-provider-click-action provider)) + (functionp (status-provider-click-action provider)))))) + providers)) + (error 'invalid-transition :description "Status providers must be functions or valid STATUS-PROVIDER objects.")) + (let ((managed (remove-if #'functionp providers))) + (unless (= (length managed) + (length (remove-duplicates managed :key #'status-provider-id :test #'equal))) + (error 'invalid-transition :description "Managed status provider ids must be unique."))) + providers) + +(defun status-cancelled-p (worker) + (bt:with-lock-held ((status-worker-lock worker)) + (status-worker-cancelled-p worker))) + +(defun status-wait (worker seconds) + "Interruptible timer, for deadlines/reconnection, not continuous polling." + (bt:with-lock-held ((status-worker-lock worker)) + (unless (status-worker-cancelled-p worker) + (bt:condition-wait (status-worker-condition worker) (status-worker-lock worker) + :timeout seconds)) + (not (status-worker-cancelled-p worker)))) + +(defun %notify-status (runtime) + (bt:with-lock-held ((status-runtime-lock runtime)) + (unless (or (status-runtime-closed-p runtime) (status-runtime-dirty-p runtime)) + (setf (status-runtime-dirty-p runtime) t) + (xlib:send-event (status-runtime-target runtime) :client-message nil + :window (status-runtime-target runtime) + :type :_lime_status_changed :format 32 :data '(0 0 0 0 0)) + (xlib:display-force-output (status-runtime-display runtime))))) + +(defun %copy-status-value (value) + "Snapshot a data tree across the worker/presentation boundary. + +No mutable strings/conses are shared with a publisher or a user formatter." + (typecase value + (string (copy-seq value)) + (cons (cons (%copy-status-value (car value)) (%copy-status-value (cdr value)))) + ((or symbol number character) value) + (t (error "Status values must be scalar/string/list data, not ~S." (type-of value))))) + +(defun status-publish (worker value) + "Cache a data snapshot (NIL means unavailable), waking X when data changes. +Data may be a string, scalar, or list tree. Formatting never runs here." + (setf value (%copy-status-value value)) + (let ((changed nil)) + (bt:with-lock-held ((status-worker-lock worker)) + (unless (status-worker-cancelled-p worker) + (setf (status-worker-error worker) nil) + (unless (equal value (status-worker-value worker)) + (setf (status-worker-value worker) value changed t)))) + (when changed (%notify-status (status-worker-runtime worker)))) + (%copy-status-value value)) + +(defun %call-with-status-resource (worker cancel function) + "Register an owned resource before blocking; cancellation unblocks its I/O." + (bt:with-lock-held ((status-worker-lock worker)) + (when (status-worker-cancelled-p worker) + (funcall cancel) + (return-from %call-with-status-resource nil)) + (push cancel (status-worker-cancel-functions worker))) + (unwind-protect (funcall function) + (bt:with-lock-held ((status-worker-lock worker)) + (setf (status-worker-cancel-functions worker) + (remove cancel (status-worker-cancel-functions worker)))))) + +(defun %run-status-worker (worker) + (let ((delay 1)) + (loop until (status-cancelled-p worker) + do (let ((started (get-internal-real-time))) + (handler-case + (funcall (status-provider-run (status-worker-provider worker)) worker) + (error (condition) + ;; Disconnected services never leave stale "playing"/volume data. + (status-publish worker nil) + (bt:with-lock-held ((status-worker-lock worker)) + (setf (status-worker-error worker) (princ-to-string condition))))) + (when (> (- (get-internal-real-time) started) + (* 30 internal-time-units-per-second)) + (setf delay 1))) + (unless (status-wait worker delay) (return)) + (setf delay (min 30 (* 2 delay)))))) + +(defun %start-status-worker (runtime provider) + (let ((worker (make-status-worker :provider provider :runtime runtime))) + (setf (status-worker-thread worker) + (bt:make-thread (lambda () (%run-status-worker worker)) + :name (format nil "Lime status ~A" (status-provider-id provider)))) + worker)) + +(defun %stop-status-worker (worker) + (bt:with-lock-held ((status-worker-lock worker)) + (setf (status-worker-cancelled-p worker) t) + ;; Cancellation functions must be short, non-blocking shutdown/kill calls. + (dolist (cancel (status-worker-cancel-functions worker)) (ignore-errors (funcall cancel))) + (bt:condition-notify (status-worker-condition worker))) + (when (status-worker-thread worker) (bt:join-thread (status-worker-thread worker)))) + +(defun %make-status-runtime (backend) + (let ((display nil) (window nil)) + (handler-case + (progn + (setf display (xlib:open-default-display (x11-backend-display-name backend)) + window (xlib:create-window :parent (x11-backend-root backend) + :x -1 :y -1 :width 1 :height 1 + :override-redirect :on)) + ;; Ensure this resource exists before any publisher sends to its XID. + (xlib:display-finish-output (x11-backend-display backend)) + (xlib:intern-atom display :_lime_status_changed) + (make-status-runtime :display display :window window + :target (xlib::make-window :display display :id (xlib:window-id window)))) + (error (condition) + (when window (ignore-errors (xlib:destroy-window window))) + (when display (ignore-errors (xlib:close-display display))) + (error condition))))) + +(defun %reconcile-status-providers (backend providers) + (let* ((managed (remove-if #'functionp providers)) + (runtime (or (x11-backend-status-runtime backend) + (when managed + (setf (x11-backend-status-runtime backend) + (%make-status-runtime backend)))))) + (when runtime + (dolist (worker (copy-list (status-runtime-workers runtime))) + (unless (member (status-worker-provider worker) managed :test #'eq) + (%stop-status-worker worker) + (setf (status-runtime-workers runtime) (remove worker (status-runtime-workers runtime))))) + (dolist (provider managed) + (unless (find provider (status-runtime-workers runtime) :key #'status-worker-provider :test #'eq) + (push (%start-status-worker runtime provider) (status-runtime-workers runtime)))) + (unless managed (%shutdown-status-runtime backend))))) + +(defun %shutdown-status-runtime (backend) + (let ((runtime (x11-backend-status-runtime backend))) + (when runtime + (dolist (worker (status-runtime-workers runtime)) (%stop-status-worker worker)) + (bt:with-lock-held ((status-runtime-lock runtime)) + (setf (status-runtime-closed-p runtime) t) + (xlib:close-display (status-runtime-display runtime))) + (xlib:destroy-window (status-runtime-window runtime)) + (setf (x11-backend-status-runtime backend) nil)))) + +(defun %handle-status-notification (backend window type) + (let ((runtime (x11-backend-status-runtime backend))) + (when (and runtime (eq type :_lime_status_changed) + (= (xlib:window-id window) (xlib:window-id (status-runtime-window runtime)))) + (bt:with-lock-held ((status-runtime-lock runtime)) + (setf (status-runtime-dirty-p runtime) nil)) + (render-head-bars backend) + t))) + +(defun %format-status-segment (provider value) + "Format a snapshot outside the worker lock; source state remains untouched." + (when value + (let* ((result (funcall (status-provider-formatter provider) (%copy-status-value value))) + (segment (etypecase result + (null nil) + (string (make-head-bar-segment :text result)) + (head-bar-segment (copy-head-bar-segment result))))) + (when segment + (setf (head-bar-segment-id segment) (status-provider-id provider) + (head-bar-segment-maximum-width segment) + (or (head-bar-segment-maximum-width segment) (status-provider-maximum-width provider)) + (head-bar-segment-foreground segment) + (or (head-bar-segment-foreground segment) (status-provider-foreground provider)) + (head-bar-segment-click-action segment) + (or (head-bar-segment-click-action segment) (status-provider-click-action provider))) + (%validate-head-bar-segment segment))))) + +(defun %status-worker-snapshot (worker) + (bt:with-lock-held ((status-worker-lock worker)) + (%copy-status-value (status-worker-value worker)))) + +(defun %managed-provider-segment (backend provider) + (let* ((runtime (x11-backend-status-runtime backend)) + (worker (and runtime (find provider (status-runtime-workers runtime) + :key #'status-worker-provider :test #'eq)))) + (when worker + (%format-status-segment provider (%status-worker-snapshot worker))))) + +(defun backend-status-provider-report (backend) + "Inspect cached status and connection errors without probing services." + (let ((runtime (x11-backend-status-runtime backend))) + (when runtime + (loop for worker in (status-runtime-workers runtime) + for provider = (status-worker-provider worker) + for value = (%status-worker-snapshot worker) + collect (let ((error (bt:with-lock-held ((status-worker-lock worker)) + (status-worker-error worker))) + (text nil)) + (handler-case + (let ((segment (%format-status-segment provider value))) + (when segment (setf text (head-bar-segment-text segment)))) + (error (condition) (setf error (princ-to-string condition)))) + (list :id (status-provider-id provider) :value value :text text :error error)))))) diff --git a/src/x11/text-native.lisp b/src/x11/text-native.lisp new file mode 100644 index 0000000..733da8a --- /dev/null +++ b/src/x11/text-native.lisp @@ -0,0 +1,65 @@ +(in-package #:lime.x11) + +;;;; Narrow native boundary: no Xlib connection or toolkit event loop. +;;;; Pango shapes UTF-8; Cairo paints memory; CLX alone uploads to X11. + +(cffi:define-foreign-library ui-cairo (:unix (:or "libcairo.so.2" "libcairo.so"))) +(cffi:define-foreign-library ui-pango (:unix (:or "libpango-1.0.so.0" "libpango-1.0.so"))) +(cffi:define-foreign-library ui-pangocairo (:unix (:or "libpangocairo-1.0.so.0" "libpangocairo-1.0.so"))) +(cffi:define-foreign-library ui-gobject (:unix (:or "libgobject-2.0.so.0" "libgobject-2.0.so"))) +(cffi:define-foreign-library ui-glib (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so"))) + +(defvar *text-libraries-loaded-p* nil) +(defun %ensure-text-libraries () + (unless *text-libraries-loaded-p* + (handler-case + (progn + (dolist (library '(ui-cairo ui-pango ui-pangocairo ui-gobject ui-glib)) + (cffi:load-foreign-library library)) + (setf *text-libraries-loaded-p* t)) + (error (condition) + (error 'invalid-transition :description + (format nil "Lime fonts require Cairo and Pango (including PangoCairo): ~A" condition)))))) + +(cffi:defcstruct pango-rectangle (x :int) (y :int) (width :int) (height :int)) +(cffi:defcstruct pango-attribute (klass :pointer) (start-index :uint) (end-index :uint)) +(cffi:defcfun ("cairo_image_surface_create" %cairo-image) :pointer (format :int) (width :int) (height :int)) +(cffi:defcfun ("cairo_surface_status" %cairo-surface-status) :int (surface :pointer)) +(cffi:defcfun ("cairo_surface_destroy" %cairo-free-surface) :void (surface :pointer)) +(cffi:defcfun ("cairo_surface_flush" %cairo-flush) :void (surface :pointer)) +(cffi:defcfun ("cairo_image_surface_get_data" %cairo-data) :pointer (surface :pointer)) +(cffi:defcfun ("cairo_image_surface_get_stride" %cairo-stride) :int (surface :pointer)) +(cffi:defcfun ("cairo_surface_write_to_png" %cairo-write-png) :int (surface :pointer) (path :string)) +(cffi:defcfun ("cairo_create" %cairo-context) :pointer (surface :pointer)) +(cffi:defcfun ("cairo_status" %cairo-status) :int (context :pointer)) +(cffi:defcfun ("cairo_destroy" %cairo-free-context) :void (context :pointer)) +(cffi:defcfun ("cairo_set_source_rgb" %cairo-rgb) :void (context :pointer) (red :double) (green :double) (blue :double)) +(cffi:defcfun ("cairo_rectangle" %cairo-rectangle) :void (context :pointer) (x :double) (y :double) (width :double) (height :double)) +(cffi:defcfun ("cairo_fill" %cairo-fill) :void (context :pointer)) +(cffi:defcfun ("cairo_clip" %cairo-clip) :void (context :pointer)) +(cffi:defcfun ("cairo_save" %cairo-save) :void (context :pointer)) +(cffi:defcfun ("cairo_restore" %cairo-restore) :void (context :pointer)) +(cffi:defcfun ("cairo_move_to" %cairo-move) :void (context :pointer) (x :double) (y :double)) +(cffi:defcfun ("pango_cairo_create_layout" %pango-layout) :pointer (context :pointer)) +(cffi:defcfun ("pango_cairo_show_layout" %pango-show) :void (context :pointer) (layout :pointer)) +(cffi:defcfun ("pango_font_description_new" %pango-description) :pointer) +(cffi:defcfun ("pango_font_description_free" %pango-free-description) :void (description :pointer)) +(cffi:defcfun ("pango_font_description_set_family" %pango-family) :void (description :pointer) (family (:string :encoding :utf-8))) +(cffi:defcfun ("pango_font_description_set_absolute_size" %pango-size) :void (description :pointer) (size :double)) +(cffi:defcfun ("pango_font_description_set_weight" %pango-weight) :void (description :pointer) (weight :int)) +(cffi:defcfun ("pango_layout_set_font_description" %pango-font) :void (layout :pointer) (description :pointer)) +(cffi:defcfun ("pango_layout_set_text" %pango-text) :void (layout :pointer) (text (:string :encoding :utf-8)) (length :int)) +(cffi:defcfun ("pango_attr_list_new" %pango-attr-list-new) :pointer) +(cffi:defcfun ("pango_attr_list_unref" %pango-attr-list-unref) :void (attrs :pointer)) +(cffi:defcfun ("pango_attr_list_insert" %pango-attr-list-insert) :void (attrs :pointer) (attribute :pointer)) +(cffi:defcfun ("pango_attr_foreground_new" %pango-foreground-new) :pointer (red :uint16) (green :uint16) (blue :uint16)) +(cffi:defcfun ("pango_layout_set_attributes" %pango-set-attributes) :void (layout :pointer) (attrs :pointer)) +(cffi:defcfun ("pango_layout_set_single_paragraph_mode" %pango-single-line) :void (layout :pointer) (setting :int)) +(cffi:defcfun ("pango_layout_get_pixel_extents" %pango-extents) :void (layout :pointer) (ink :pointer) (logical :pointer)) +(cffi:defcfun ("pango_layout_get_baseline" %pango-baseline) :int (layout :pointer)) +(cffi:defcfun ("pango_layout_get_log_attrs_readonly" %pango-log-attrs) :pointer (layout :pointer) (count :pointer)) +(cffi:defcfun ("pango_layout_get_unknown_glyphs_count" %pango-unknown-glyphs) :int (layout :pointer)) +(cffi:defcfun ("pango_layout_get_line_readonly" %pango-line) :pointer (layout :pointer) (line :int)) +(cffi:defcfun ("pango_layout_line_get_x_ranges" %pango-x-ranges) :void (line :pointer) (start :int) (end :int) (ranges :pointer) (count :pointer)) +(cffi:defcfun ("g_object_unref" %g-unref) :void (object :pointer)) +(cffi:defcfun ("g_free" %g-free) :void (memory :pointer)) diff --git a/src/x11/text.lisp b/src/x11/text.lisp new file mode 100644 index 0000000..842692e --- /dev/null +++ b/src/x11/text.lisp @@ -0,0 +1,281 @@ +(in-package #:lime.x11) + +;;;; Shared shaping and painting policy. Bar/overlay resources belong to the +;;;; backend thread, never to the model. All native objects have explicit owners. + +(defstruct ui-font-style (family "monospace") (size 14) (weight :normal)) +(defparameter *default-ui-font-style* (make-ui-font-style)) +(declaim (ftype function lime-configuration-font)) + +(defun %configured-font (backend) + (declare (notinline lime-configuration-font)) + (if (x11-backend-configuration backend) + (lime-configuration-font (x11-backend-configuration backend)) + *default-ui-font-style*)) + +(defun %validate-ui-font-style (style) + (unless (and (typep style 'ui-font-style) + (stringp (ui-font-style-family style)) + (plusp (length (string-trim '(#\Space #\Tab) (ui-font-style-family style)))) + (notany (lambda (c) (or (< (char-code c) 32) (<= 127 (char-code c) 159) + (member (char-code c) '(#x2028 #x2029)))) + (ui-font-style-family style)) + (realp (ui-font-style-size style)) (<= 1 (ui-font-style-size style) 96) + (member (ui-font-style-weight style) '(:normal :bold))) + (error 'invalid-transition :description + "Font needs a nonempty family string, pixel :SIZE from 1 to 96, and :WEIGHT :NORMAL or :BOLD.")) + style) + +(defstruct ui-canvas surface context width height pixels) +(defstruct ui-text-font style canvas description layout (metrics (make-hash-table :test #'equal))) +(defstruct text-metrics width height left top baseline ink-top ink-height boundaries unknown-glyphs) + +(defun %make-ui-canvas (width height) + (%ensure-text-libraries) + (let ((surface (%cairo-image 1 width height)) ; RGB24, native 32-bit pixels + (context nil) (success nil)) + (unwind-protect + (progn + (unless (zerop (%cairo-surface-status surface)) + (error "Cannot allocate UI surface ~Dx~D." width height)) + (setf context (%cairo-context surface)) + (unless (zerop (%cairo-status context)) (error "Cannot create UI paint context.")) + (prog1 (make-ui-canvas :surface surface :context context :width width :height height) + (setf success t))) + (unless success + (when context (%cairo-free-context context)) + (%cairo-free-surface surface))))) + +(defun %free-ui-canvas (canvas) + (when (and canvas (ui-canvas-surface canvas)) + (%cairo-free-context (ui-canvas-context canvas)) + (%cairo-free-surface (ui-canvas-surface canvas)) + (setf (ui-canvas-context canvas) nil (ui-canvas-surface canvas) nil))) + +(defun %free-text-font (font) + (when font + (when (ui-text-font-layout font) (%g-unref (ui-text-font-layout font))) + (when (ui-text-font-description font) (%pango-free-description (ui-text-font-description font))) + (%free-ui-canvas (ui-text-font-canvas font)) + (setf (ui-text-font-layout font) nil (ui-text-font-description font) nil))) + +(defun %open-text-font (style) + (%validate-ui-font-style style) + (let ((font (make-ui-text-font :style (copy-ui-font-style style))) (success nil)) + (unwind-protect + (progn + (setf (ui-text-font-canvas font) (%make-ui-canvas 1 1) + (ui-text-font-description font) (%pango-description)) + (%pango-family (ui-text-font-description font) (ui-font-style-family style)) + (%pango-size (ui-text-font-description font) (* 1024d0 (ui-font-style-size style))) + (%pango-weight (ui-text-font-description font) (if (eq :bold (ui-font-style-weight style)) 700 400)) + (setf (ui-text-font-layout font) (%pango-layout (ui-canvas-context (ui-text-font-canvas font)))) + (%pango-font (ui-text-font-layout font) (ui-text-font-description font)) + (%pango-single-line (ui-text-font-layout font) 1) + (prog1 font (setf success t))) + (unless success (%free-text-font font))))) + +(defun %ensure-text-font (font style) + "Construct before releasing the old font, so a failed open keeps it alive." + (if (and font (equalp (ui-text-font-style font) style)) font + (let ((new (%open-text-font style))) (%free-text-font font) new))) + +(defun %ensure-ui-canvas (canvas width height) + (if (and canvas (= width (ui-canvas-width canvas)) (= height (ui-canvas-height canvas))) + canvas (let ((new (%make-ui-canvas width height))) (%free-ui-canvas canvas) new))) + +(defun %single-line-text (text) + "Preserve Unicode (including combining marks/ZWJ), but keep UI fields one line." + (map 'string (lambda (c) + (if (or (< (char-code c) 32) (<= 127 (char-code c) 159) + (member (char-code c) '(#x2028 #x2029))) #\Space c)) + (princ-to-string text))) + +(defun %prepare-text (font text) + (%pango-text (ui-text-font-layout font) (%single-line-text text) -1)) + +(defun %text-metrics (font text) + (or (gethash text (ui-text-font-metrics font)) + (progn + (%prepare-text font text) + (cffi:with-foreign-objects ((ink '(:struct pango-rectangle)) (logical '(:struct pango-rectangle)) (count :int)) + (%pango-extents (ui-text-font-layout font) ink logical) + (flet ((field (rect key) (cffi:foreign-slot-value rect '(:struct pango-rectangle) key))) + (let* ((left (min 0 (field ink 'x) (field logical 'x))) + (top (min 0 (field ink 'y) (field logical 'y))) + (right (max (+ (field ink 'x) (field ink 'width)) + (+ (field logical 'x) (field logical 'width)))) + (bottom (max (+ (field ink 'y) (field ink 'height)) + (+ (field logical 'y) (field logical 'height)))) + (attrs (%pango-log-attrs (ui-text-font-layout font) count)) + ;; Native guint bitfield in PangoLogAttr (Linux ABI). + (cursor-bit #+little-endian 4 #-little-endian 27) + (boundaries (coerce (loop for i below (cffi:mem-ref count :int) + when (logbitp cursor-bit (cffi:mem-aref attrs :uint i)) + collect i) 'vector)) + (metrics (make-text-metrics :width (- right left) :height (- bottom top) + :left left :top top :boundaries boundaries + :baseline (round (%pango-baseline (ui-text-font-layout font)) 1024) + :ink-top (field ink 'y) :ink-height (field ink 'height) + :unknown-glyphs (%pango-unknown-glyphs (ui-text-font-layout font))))) + (when (>= (hash-table-count (ui-text-font-metrics font)) 256) + (clrhash (ui-text-font-metrics font))) + (setf (gethash (copy-seq text) (ui-text-font-metrics font)) metrics))))))) + +(defun %text-width (font text) (text-metrics-width (%text-metrics font text))) +(defun %font-line-height (font) (max 1 (text-metrics-height (%text-metrics font "Mg")))) + +(defun %font-centered-baseline (font height) + "Center a stable letter-body sample, not font leading or each changing title. + +Including uppercase, lowercase ascenders, and digits captures the ordinary +body without letting descenders move every label upward. All fields share +this baseline; accents, descenders, and fallback glyphs keep their bearings." + (let ((reference (%text-metrics font "ABCabc012"))) + (+ (floor (- height (text-metrics-ink-height reference)) 2) + (- (text-metrics-baseline reference) (text-metrics-ink-top reference))))) + +(defun %fit-text (text maximum-width measure &optional boundaries) + "Fit shaped text at supplied grapheme boundaries, retaining the source count." + (let ((string (princ-to-string text))) + (cond + ((<= maximum-width 0) (values "" 0)) + ((<= (funcall measure string) maximum-width) (values string (length string))) + (t + (let* ((suffix (if (<= (funcall measure "...") maximum-width) "..." "")) + (ends (or boundaries (coerce (loop for i from 0 to (length string) collect i) 'vector))) + (low 0) (high (1- (length ends)))) + (loop while (< low high) + for middle = (ceiling (+ low high) 2) + for candidate = (concatenate 'string (subseq string 0 (aref ends middle)) suffix) + do (if (<= (funcall measure candidate) maximum-width) + (setf low middle) (setf high (1- middle)))) + (let ((prefix (aref ends low))) + (values (concatenate 'string (subseq string 0 prefix) suffix) prefix))))))) + +(defun %fit-ui-text (font text maximum-width) + (let ((string (%single-line-text text))) + (%fit-text string maximum-width (lambda (s) (%text-width font s)) + (text-metrics-boundaries (%text-metrics font string))))) + +(defun %text-prefix-ranges (font text prefix) + "Actual visual ranges of source text, excluding truncation dots even in RTL." + (when (plusp prefix) + (let ((metrics (%text-metrics font text))) + (%prepare-text font text) + (cffi:with-foreign-objects ((ranges :pointer) (count :int)) + (%pango-x-ranges (%pango-line (ui-text-font-layout font) 0) 0 + (length (babel:string-to-octets (subseq (%single-line-text text) 0 prefix) :encoding :utf-8)) + ranges count) + (let ((data (cffi:mem-ref ranges :pointer))) + (unwind-protect + (loop for i below (cffi:mem-ref count :int) + for left = (- (floor (cffi:mem-aref data :int (* 2 i)) 1024) (text-metrics-left metrics)) + for right = (- (ceiling (cffi:mem-aref data :int (1+ (* 2 i))) 1024) (text-metrics-left metrics)) + collect (cons (max 0 left) (min right (text-metrics-width metrics)))) + (%g-free data))))))) + +(defun %canvas-color (canvas color) + (%cairo-rgb (ui-canvas-context canvas) + (/ (parse-integer color :start 1 :end 3 :radix 16) 255d0) + (/ (parse-integer color :start 3 :end 5 :radix 16) 255d0) + (/ (parse-integer color :start 5 :end 7 :radix 16) 255d0))) + +(defun %canvas-rectangle (canvas x y width height color) + (when (and (plusp width) (plusp height)) + (%canvas-color canvas color) + (%cairo-rectangle (ui-canvas-context canvas) (float x 1d0) (float y 1d0) + (float width 1d0) (float height 1d0)) + (%cairo-fill (ui-canvas-context canvas)))) + +(defun %text-prefix-attributes (text prefix color) + "Pango indexes UTF-8 bytes, while our public prefix length counts characters." + (let ((attrs (%pango-attr-list-new)) (success nil)) + (unwind-protect + (let ((attribute (%pango-foreground-new + (* 257 (parse-integer color :start 1 :end 3 :radix 16)) + (* 257 (parse-integer color :start 3 :end 5 :radix 16)) + (* 257 (parse-integer color :start 5 :end 7 :radix 16))))) + ;; Insertion transfers ownership to the list, including on unwind. + (%pango-attr-list-insert attrs attribute) + (setf (cffi:foreign-slot-value attribute '(:struct pango-attribute) 'start-index) 0 + (cffi:foreign-slot-value attribute '(:struct pango-attribute) 'end-index) + (length (babel:string-to-octets + (subseq (%single-line-text text) 0 (min prefix (length text))) + :encoding :utf-8)) + success t) + attrs) + (unless success (%pango-attr-list-unref attrs))))) + +(defun %canvas-text (canvas font text x y width height color &key baseline (prefix-length 0) prefix-color) + "Paint a clipped field; BASELINE optionally aligns it to a shared row baseline. + +BASELINE is relative to Y. Without it, center the complete font line box. +An optional colored prefix stays in the same shaped layout, including for RTL." + (when (and (plusp width) (plusp height) (plusp (length text))) + (let ((context (ui-canvas-context canvas)) (metrics (%text-metrics font text)) (attrs nil)) + (%prepare-text font text) + (%cairo-save context) + (unwind-protect + (progn + (when (and prefix-color (plusp prefix-length)) + (setf attrs (%text-prefix-attributes text prefix-length prefix-color)) + (%pango-set-attributes (ui-text-font-layout font) attrs)) + (%cairo-rectangle context (float x 1d0) (float y 1d0) (float width 1d0) (float height 1d0)) + (%cairo-clip context) + (%canvas-color canvas color) + (%cairo-move context (float (- x (text-metrics-left metrics)) 1d0) + (float (if baseline + (- (+ y baseline) (text-metrics-baseline metrics)) + (- (+ y (floor (- height (text-metrics-height metrics)) 2)) + (text-metrics-top metrics))) 1d0)) + (%pango-show context (ui-text-font-layout font))) + (when attrs + (%pango-set-attributes (ui-text-font-layout font) (cffi:null-pointer)) + (%pango-attr-list-unref attrs)) + (%cairo-restore context))))) + +(defun %rgb-channel-to-mask (byte mask) + (if (zerop mask) 0 + (let* ((shift (1- (integer-length (logand mask (- mask))))) + (maximum (ash mask (- shift)))) + (ash (round (* byte maximum) 255) shift)))) + +(defun %rgb-to-visual-pixel (pixel red green blue depth) + (logior (%rgb-channel-to-mask (ldb (byte 8 16) pixel) red) + (%rgb-channel-to-mask (ldb (byte 8 8) pixel) green) + (%rgb-channel-to-mask (ldb (byte 8 0) pixel) blue) + (logand (1- (ash 1 depth)) (lognot (logior red green blue))))) + +(defun %present-ui-canvas (backend canvas window gcontext) + "Upload an opaque frame on CLX's connection; no cross-connection races." + (unless (zerop (%cairo-status (ui-canvas-context canvas))) (error "UI painting failed.")) + (%cairo-flush (ui-canvas-surface canvas)) + (let* ((screen (x11-backend-x-screen backend)) + (visual (xlib:screen-root-visual-info screen)) + (depth (xlib:screen-root-depth screen)) + (format (find depth (xlib:display-pixmap-formats (x11-backend-display backend)) + :key #'xlib:pixmap-format-depth)) + (bits-per-pixel (xlib:pixmap-format-bits-per-pixel format)) + (red (xlib:visual-info-red-mask visual)) (green (xlib:visual-info-green-mask visual)) + (blue (xlib:visual-info-blue-mask visual)) + (direct-p (and (= depth 24) (= red #xff0000) (= green #xff00) (= blue #xff))) + (data (%cairo-data (ui-canvas-surface canvas))) + (stride (%cairo-stride (ui-canvas-surface canvas))) + ;; CLX's upload array must match the server's storage, not just its + ;; visual depth: ordinary 24-bit visuals usually use 32-bit pixels. + (pixels (or (ui-canvas-pixels canvas) + (setf (ui-canvas-pixels canvas) + (make-array (list (ui-canvas-height canvas) (ui-canvas-width canvas)) + :element-type (list 'unsigned-byte bits-per-pixel)))))) + (unless (eq :true-color (xlib:visual-info-class visual)) + (error 'invalid-transition :description "Lime's font renderer requires a TrueColor X11 visual.")) + (dotimes (y (ui-canvas-height canvas)) + (dotimes (x (ui-canvas-width canvas)) + (let ((pixel (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4))))) + (setf (aref pixels y x) + (if direct-p (logand pixel #xffffff) + (%rgb-to-visual-pixel pixel red green blue depth)))))) + (xlib:put-image window gcontext + (xlib:create-image :data pixels :depth depth :bits-per-pixel bits-per-pixel) + :x 0 :y 0))) diff --git a/src/x11/ui-render.lisp b/src/x11/ui-render.lisp new file mode 100644 index 0000000..7be5316 --- /dev/null +++ b/src/x11/ui-render.lisp @@ -0,0 +1,295 @@ +(in-package #:lime.x11) + +;;;; X11 presentation only. Command trees/actions live in ui.lisp; navigation +;;;; and picker/prompt transitions live in lime.ui. Geometry helpers need no X. + +(defstruct x11-ui-overlay + window font canvas foreground-gcontext head-id height hit-regions hovered-action + pointer-position pointer-hand-p) + +(defstruct ui-hit-region x y width height action) + +(defun %ui-hit-at (overlay x y) + (find-if (lambda (hit) + (and (<= (ui-hit-region-x hit) x) + (< x (+ (ui-hit-region-x hit) (ui-hit-region-width hit))) + (<= (ui-hit-region-y hit) y) + (< y (+ (ui-hit-region-y hit) (ui-hit-region-height hit))))) + (x11-ui-overlay-hit-regions overlay))) + +(defun %ui-draw-hit (overlay canvas style action x y width height) + "Register the actual clipped paint rectangle, and highlight pointer hover." + (let* ((left (max 0 x)) (top (max 0 y)) + (right (min (ui-canvas-width canvas) (+ x width))) + (bottom (min (ui-canvas-height canvas) (+ y height)))) + (when (and (< left right) (< top bottom)) + (push (make-ui-hit-region :x left :y top :width (- right left) + :height (- bottom top) :action action) + (x11-ui-overlay-hit-regions overlay)) + (when (let ((point (x11-ui-overlay-pointer-position overlay))) + (and point (<= left (car point)) (< (car point) right) + (<= top (cdr point)) (< (cdr point) bottom))) + (setf (x11-ui-overlay-hovered-action overlay) action) + (%canvas-rectangle canvas left top (- right left) (- bottom top) + (head-bar-style-unfocused-background style)) + (%canvas-rectangle canvas left (1- bottom) (- right left) 1 + (%ui-accent-color style)))))) + +(defun %ui-row-height (font) (max 24 (+ 8 (%font-line-height font)))) + +(defun %ui-key-label (key) + (if (char= key #\Space) "SPC" (string key))) + +(defun %ui-menu-entries (session) + "Presentation data for this prefix only; descriptions stay out of the grid." + (append + (mapcar (lambda (node) + (list :key (%ui-key-label (ui-key-node-key node)) + :action (list :key (ui-key-node-key node)) + :label (format nil "~A~A" (if (ui-key-node-children node) "+" "") + (ui-key-node-label node)) + :branch-p (not (null (ui-key-node-children node))))) + (ui-session-key-nodes session)) + (unless (find #\Space (ui-session-key-nodes session) :key #'ui-key-node-key) + (list (list :key "SPC" :label "Search commands" :action '(:key #\Space)))))) + +(defun %ui-key-grid-layout (entries width maximum-height row-height measure &optional (page 0)) + "A measured, paged which-key grid. Every entry fits its own clipped cell." + (let* ((padding (min 12 (floor width 2))) + (usable (max 0 (- width (* 2 padding)))) + (gap 20) + (key-width (+ 8 (funcall measure "SPC →"))) + (preferred (min 340 (max 180 (+ key-width 12 + (loop for entry in entries maximize + (funcall measure (getf entry :label)) into largest + finally (return (or largest 0))))))) + (columns (max 1 (min 4 (floor (+ usable gap) (+ preferred gap))))) + (cell-width (max 0 (floor (- usable (* (1- columns) gap)) columns))) + (header (+ row-height 12)) + (footer (+ row-height 8)) + (maximum-rows (max 0 (min 6 (floor (- maximum-height header footer) row-height)))) + (rows (min maximum-rows (max 1 (ceiling (length entries) columns)))) + (capacity (* columns rows)) + (pages (max 1 (ceiling (length entries) (max 1 capacity)))) + (page (min (max 0 page) (1- pages))) + (start (min (length entries) (* page capacity)))) + (list :height (max 1 (min maximum-height (+ header (* rows row-height) footer))) + :header-height header :footer-height footer :padding padding + :columns columns :rows rows :cell-width cell-width :gap gap :key-width key-width + :capacity capacity :page page :page-count pages + :start start :end (min (length entries) (+ start capacity))))) + +(defun %ui-visible-range (count selected capacity) + (let ((start (min (max 0 (- count capacity)) (max 0 (- (1+ selected) capacity))))) + (values start (min count (+ start capacity))))) + +(defun %ui-list-layout (session maximum-height row-height) + (let* ((header (+ row-height 12)) + (footer (+ row-height 8)) + (detail (if (eq (ui-session-mode session) :search) row-height 0)) + (maximum-rows (max 0 (min 8 (floor (- maximum-height header footer detail) row-height)))) + (rows (if (eq (ui-session-mode session) :prompt) 0 + (min maximum-rows (max 1 (length (ui-session-candidates session))))))) + (list :height (max 1 (min maximum-height (+ header (* rows row-height) detail footer))) + :header-height header :footer-height footer :detail-height detail :rows rows))) + +(defun %ui-overlay-layout (session font area) + (let* ((width (max 1 (x11-work-area-width area))) + ;; Keep the command surface a dropdown even for large/custom trees. + (maximum-height (max 1 (min (x11-work-area-height area) + (max 240 (floor (x11-work-area-height area) 2))))) + (row-height (%ui-row-height font))) + (if (eq (ui-session-mode session) :key-path) + (%ui-key-grid-layout (%ui-menu-entries session) width maximum-height row-height + (lambda (text) (%text-width font text)) (ui-session-key-page session)) + (%ui-list-layout session maximum-height row-height)))) + +(defun %make-ui-overlay (backend head-id session) + (let* ((area (x11-head-work-area backend (%head-for-id backend head-id))) + (overlay (make-x11-ui-overlay :head-id head-id)) + (success nil)) + (unwind-protect + (progn + (setf (x11-ui-overlay-font overlay) (%open-text-font (%configured-font backend)) + (x11-ui-overlay-height overlay) + (getf (%ui-overlay-layout session (x11-ui-overlay-font overlay) area) :height) + (x11-ui-overlay-window overlay) + (xlib:create-window + :parent (x11-backend-root backend) + :x (x11-work-area-x area) :y (x11-work-area-y area) + :width (max 1 (x11-work-area-width area)) :height (x11-ui-overlay-height overlay) + :background (xlib:screen-black-pixel (x11-backend-x-screen backend)) + ;; Paint the themed outline inside the canvas; no extra X + ;; border outside the Head and no separate colormap allocation. + :border-width 0 :override-redirect :on + :event-mask '(:exposure :key-press :button-press :pointer-motion :enter-window :leave-window)) + (x11-ui-overlay-foreground-gcontext overlay) + (xlib:create-gcontext :drawable (x11-ui-overlay-window overlay))) + (setf success t) + overlay) + (unless success (%free-ui-overlay overlay))))) + +(defun %free-ui-overlay (overlay) + (when overlay + (when (x11-ui-overlay-foreground-gcontext overlay) + (xlib:free-gcontext (x11-ui-overlay-foreground-gcontext overlay))) + (%free-text-font (x11-ui-overlay-font overlay)) + (%free-ui-canvas (x11-ui-overlay-canvas overlay)) + (when (x11-ui-overlay-window overlay) (xlib:destroy-window (x11-ui-overlay-window overlay))))) + +(defun %ui-menu-heading (session) + (format nil "Lime~{ › ~A~}" + (mapcar (lambda (node) (format nil "~A ~A" (%ui-key-label (ui-key-node-key node)) + (ui-key-node-label node))) + (ui-session-key-path session)))) + +(defun %ui-draw-field (canvas font text x y width height color) + (%canvas-text canvas font (%fit-ui-text font (or text "") (max 0 width)) + x y (max 0 width) (max 0 height) color + :baseline (%font-centered-baseline font height))) + +(defun %ui-draw-buttons (overlay canvas font style buttons left right y height) + "Paint right-aligned controls, returning the remaining text area's right edge. + +BUTTONS are (label action) pairs, rightmost first. Omit controls that cannot +fit rather than making invisible text into a surprising click target." + (dolist (button buttons) + (let* ((label (first button)) (action (second button)) + (width (+ 12 (%text-width font label))) + (x (- right width))) + (when (>= x left) + (%ui-draw-hit overlay canvas style action x y width height) + (%ui-draw-field canvas font label (+ x 6) y (- width 12) height + (%ui-accent-color style)) + (setf right (- x 8))))) + (max left right)) + +(defun %ui-header-buttons (session) + (append (list (list "Close" '(:key :escape))) + (case (ui-session-mode session) + (:key-path + (append (list (list "Search" '(:key :tab))) + (when (ui-session-key-path session) + (list (list "Back" '(:key :backspace)))))) + (:search (when (ui-session-key-root session) + (list (list "Menu" '(:key :tab))))) + (:prompt (list (list "Confirm" '(:key :return))))))) + +(defun %ui-draw-key-grid (overlay canvas font session layout style) + (let* ((row-height (%ui-row-height font)) + (cell-width (getf layout :cell-width)) + (key-width (min cell-width (getf layout :key-width))) + (entries (%ui-menu-entries session))) + ;; Page navigation is session state, bounded by this font/Head's viewport. + (setf (ui-session-key-page session) (getf layout :page)) + (loop for entry in (subseq entries (getf layout :start) (getf layout :end)) + for index from 0 + for column = (mod index (getf layout :columns)) + for row = (floor index (getf layout :columns)) + for x = (+ (getf layout :padding) (* column (+ cell-width (getf layout :gap)))) + for y = (+ (getf layout :header-height) (* row row-height)) + do (%ui-draw-hit overlay canvas style (getf entry :action) x y cell-width row-height) + (%ui-draw-field canvas font (format nil "~A →" (getf entry :key)) + x y key-width row-height (%ui-accent-color style)) + (%ui-draw-field canvas font (getf entry :label) (+ x key-width) y + (- cell-width key-width) row-height + (if (getf entry :branch-p) (%ui-menu-label-color style) + (head-bar-style-foreground style)))))) + +(defun %ui-draw-search-list (overlay canvas font session layout style width) + (let ((row-height (%ui-row-height font)) + (candidates (ui-session-candidates session)) + (selected (ui-session-selected-index session)) + (padding (min 12 (floor width 2)))) + (multiple-value-bind (start end) (%ui-visible-range (length candidates) selected (getf layout :rows)) + (loop for candidate in (subseq candidates start end) for index from start + for top = (+ (getf layout :header-height) (* (- index start) row-height)) + do (when (= index selected) + (%canvas-rectangle canvas 4 top (max 0 (- width 8)) row-height + (head-bar-style-focused-background style)) + (%canvas-rectangle canvas 4 top (min 2 (max 0 (- width 4))) row-height + (%ui-accent-color style))) + (%ui-draw-hit overlay canvas style (list :candidate candidate) + 4 top (max 0 (- width 8)) row-height) + (%ui-draw-field canvas font (ui-candidate-label candidate) padding top + (- width (* 2 padding)) row-height + (if (= index selected) (head-bar-style-focused-foreground style) + (head-bar-style-foreground style)))) + (when (and (null candidates) (plusp (getf layout :rows))) + (%ui-draw-field canvas font "No matching command." padding (getf layout :header-height) + (- width (* 2 padding)) row-height (head-bar-style-unfocused-foreground style)))))) + +(defun %render-command-palette (backend) + (let ((session (x11-backend-ui-session backend)) + (overlay (x11-backend-ui-overlay backend))) + (when (and session overlay) + (let* ((font (setf (x11-ui-overlay-font overlay) + (%ensure-text-font (x11-ui-overlay-font overlay) (%configured-font backend)))) + (area (x11-head-work-area backend (%head-for-id backend (x11-ui-overlay-head-id overlay)))) + (window (x11-ui-overlay-window overlay)) + (width (max 1 (x11-work-area-width area))) + (layout (%ui-overlay-layout session font area)) + (height (getf layout :height)) + (row-height (%ui-row-height font)) + (padding (min 12 (floor width 2))) + (style (%head-bar-style backend)) + (line (or (head-bar-style-title-edge-color style) (head-bar-style-separator-color style))) + (canvas (setf (x11-ui-overlay-canvas overlay) + (%ensure-ui-canvas (x11-ui-overlay-canvas overlay) width height)))) + (xlib:with-state (window) + (setf (xlib:drawable-x window) (x11-work-area-x area) + (xlib:drawable-y window) (x11-work-area-y area) + (xlib:drawable-width window) width (xlib:drawable-height window) height)) + (setf (x11-ui-overlay-height overlay) height + (x11-ui-overlay-hit-regions overlay) nil + (x11-ui-overlay-hovered-action overlay) nil + (x11-ui-overlay-pointer-position overlay) (%ui-window-pointer-position backend window)) + (%canvas-rectangle canvas 0 0 width height (head-bar-style-background style)) + (%canvas-rectangle canvas 0 0 width (min height (getf layout :header-height)) + (head-bar-style-focused-background style)) + (let ((heading-right + (%ui-draw-buttons overlay canvas font style (%ui-header-buttons session) + padding (- width padding) 4 + (max 0 (min row-height (- height 4)))))) + (%ui-draw-field canvas font + (case (ui-session-mode session) + (:key-path (%ui-menu-heading session)) + (:search (format nil "Search ~A_" (ui-session-query session))) + (:prompt (format nil "~A ~A_" (ui-session-prompt session) (ui-session-query session)))) + padding 4 (- heading-right padding) (max 0 (min row-height (- height 4))) + (if (eq (ui-session-mode session) :key-path) + (or (head-bar-style-accent-color style) (head-bar-style-foreground style)) + (head-bar-style-foreground style)))) + (case (ui-session-mode session) + (:key-path (%ui-draw-key-grid overlay canvas font session layout style)) + (:search (%ui-draw-search-list overlay canvas font session layout style width))) + (when (>= height (+ (getf layout :header-height) (getf layout :footer-height))) + (let* ((footer-y (- height (getf layout :footer-height))) + (status (ui-session-status session)) + (status-right (- width padding))) + (%canvas-rectangle canvas padding footer-y (- width (* 2 padding)) 1 line) + (when (and (eq (ui-session-mode session) :search) + (>= footer-y (+ (getf layout :header-height) row-height))) + (let ((candidate (ui-session-selected-candidate session))) + (%ui-draw-field canvas font (and candidate (ui-candidate-detail candidate)) + padding (- footer-y row-height) (- width (* 2 padding)) row-height + (head-bar-style-unfocused-foreground style)))) + (when (and (eq (ui-session-mode session) :key-path) (> (getf layout :page-count) 1)) + (setf status (format nil "PgUp/PgDn ~D/~D · ~A" (1+ (getf layout :page)) + (getf layout :page-count) status) + status-right + (%ui-draw-buttons + overlay canvas font style + (append (when (< (getf layout :page) (1- (getf layout :page-count))) + (list (list ">" '(:key :page-down)))) + (when (plusp (getf layout :page)) + (list (list "<" '(:key :page-up))))) + padding status-right (+ footer-y 4) row-height))) + (%ui-draw-field canvas font status padding (+ footer-y 4) + (- status-right padding) row-height (head-bar-style-unfocused-foreground style)))) + (%canvas-rectangle canvas 0 (1- height) width 1 line) + (%present-ui-canvas backend canvas window (x11-ui-overlay-foreground-gcontext overlay)) + (setf (x11-ui-overlay-pointer-hand-p overlay) + (%set-ui-pointer backend window (x11-ui-overlay-hovered-action overlay) + (x11-ui-overlay-pointer-hand-p overlay))) + (xlib:display-force-output (x11-backend-display backend)))))) diff --git a/src/x11/ui.lisp b/src/x11/ui.lisp new file mode 100644 index 0000000..ffb1256 --- /dev/null +++ b/src/x11/ui.lisp @@ -0,0 +1,1451 @@ +(in-package #:lime.x11) + +(declaim (ftype function %ui-activity-monitor-candidates %ui-extend-activity-result + %ui-portable-activity-result)) + +;;;; X11 command-palette adapter +;;; +;;; LIME.UI owns generic menu/search/prompt state. This file builds commands +;;; and key trees and routes grabbed input. UI-RENDER owns the overlay's X11 +;;; resources, measured layout, and paint; neither layer owns model policy. + +(defun backend-command-palette-open-p (backend) + "Return true when BACKEND currently owns an interactive command palette." + (not (null (x11-backend-ui-session backend)))) + +(defun %ui-display-name (value) + (princ-to-string value)) + +(defun %ui-activity-candidates (backend) + "Build Activity and View candidates from the current durable model state." + (let* ((world (x11-backend-world backend)) + (activities + (sort (copy-list (list-activities world)) #'string-lessp + :key (lambda (activity) + (string-downcase (%ui-display-name (activity-name activity)))))) + (candidates '())) + (dolist (activity activities) + (let* ((activity-id (activity-id activity)) + (activity-name (activity-name activity)) + (view-ids (activity-view-ids activity))) + ;; Activities are useful without a saved checkpoint. Their direct + ;; action resumes the last Head-local arrangement; View entries + ;; below are the distinct explicit checkpoint recalls. + (push (make-ui-candidate + :id (list :activity activity-id) + :label (format nil "Activity ~D: ~A" (backend-activity-slot backend activity-id) activity-name) + :detail (let ((count (length (backend-attention-client-ids + backend :activity-id activity-id)))) + (if (plusp count) + (format nil "! ~D window~:P need attention; resume its arrangement" count) + (if (eq :portable (backend-activity-navigation-mode backend activity-id)) + "bring here; swap monitors if already displayed" + "extended Activity: resume this monitor's portion"))) + :key-hint "Enter" + :action (lambda () + (%ui-request-activity-activation backend activity-id))) + candidates) + (dolist (view-id view-ids) + (let ((view (find-view world view-id))) + (let ((candidate-view-id view-id)) + (push (make-ui-candidate + :id (list :view candidate-view-id) + :label (format nil "Recall view ~D: ~A / ~A" (backend-view-slot backend view-id) activity-name (view-name view)) + :detail "apply this saved arrangement on this monitor" + :key-hint "Enter" + :action (lambda () + (%ui-request-view-activation backend candidate-view-id :recall-p t))) + candidates)))))) + (nreverse candidates))) + +(defun %ui-delete-activity-detail (summary) + (cond + ((getf summary :client-ids) + (format nil "~D owned window~:P (including hidden/shared); move or close them first" + (length (getf summary :client-ids)))) + ((getf summary :head-ids) + (format nil "in use on ~{~A~^, ~}; switch those Heads away first" + (getf summary :head-ids))) + (t (format nil "remove ~D saved View~:P, ~D cached draft~:P, ~D Viewset entr~:@P; ~D empty Viewset~:P removed" + (length (getf summary :view-ids)) (length (getf summary :presentation-ids)) + (getf summary :viewset-entry-count) (length (getf summary :empty-viewset-ids)))))) + +(defun %ui-delete-activity-result (backend activity-id) + (let ((summary (activity-deletion-summary (x11-backend-world backend) activity-id))) + (if (not (getf summary :ready-p)) + (ui-keep-open-result (%ui-delete-activity-detail summary)) + (ui-replace-result + (list + ;; Default selection is deliberately non-destructive. Opening a + ;; picker, or repeating Enter accidentally, must not erase a task. + (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" + :action (lambda () (ui-close-result))) + (make-ui-candidate + :id (list :confirm-delete-activity activity-id) + :label (format nil "Delete Activity: ~A" (getf summary :name)) + :detail (%ui-delete-activity-detail summary) :key-hint "Enter" + :action (lambda () + (handler-case + (progn + (backend-delete-activity backend activity-id :expected-revision (getf summary :revision)) + (ui-close-result (format nil "Deleted Activity: ~A." (getf summary :name)))) + (stale-transition-plan () + (ui-keep-open-result "The desk changed. Cancel and choose the Activity again to review deletion.")))))) + (format nil "Delete ~A and its saved arrangements? No undo. No application will be closed." + (getf summary :name)))))) + +(defun %ui-delete-activity-picker-result (backend) + (let ((world (x11-backend-world backend))) + (ui-replace-result + (loop for activity in (list-activities world) + collect + (let ((id (activity-id activity))) + (make-ui-candidate + :id (list :delete-activity id) :label (activity-name activity) :key-hint "Enter" + :detail (%ui-delete-activity-detail (activity-deletion-summary world id)) + :action (lambda () (%ui-delete-activity-result backend id))))) + "Choose an empty Activity not displayed on any Head. Deletion requires confirmation."))) + +(defun %ui-client-label (world client-id) + "Return a short human label for one managed Activity client." + (let ((client (find-client world client-id))) + (or (client-name client) client-id))) + +(defun %ui-live-client-label (backend client-id) + "Use the current application title, not a stale checkpoint name or XID." + (let ((info (backend-client-icccm-info backend client-id))) + (or (and info (%nonempty-title (icccm-client-info-title info))) + (and info (%nonempty-title (icccm-client-info-resource-class info))) + (%ui-client-label (x11-backend-world backend) client-id)))) + +(defun %ui-attend-client-result (backend client-id &key (policy :strict)) + "Visit an attention target without taking a window from another Head. + +Leased clients are focused where they already live. Hidden clients are shown +in their own Activity; draft collisions still require the ordinary explicit +partial/take decision. Recheck everything after time spent in the picker." + (unless (backend-client-needs-attention-p backend client-id) + (return-from %ui-attend-client-result + (ui-keep-open-result "That window no longer needs attention."))) + (let* ((world (x11-backend-world backend)) + (activity-id (client-activity-id (find-client world client-id))) + (leased-head (ewmh-active-head-id-for-client backend client-id)) + (head-id (x11-backend-focused-head-id backend)) + (presentation (current-presentation world head-id))) + (if (or leased-head + (not (eq policy :strict)) + (and presentation + (client-available-in-activity-p world client-id (presentation-activity-id presentation)))) + (progn + (backend-attend-client backend client-id :policy policy) + (ui-close-result "Attention window shown on its Head.")) + (let ((report (backend-preflight-activity-activation backend activity-id))) + (cond + ((activation-report-ready-p report) + (backend-attend-client backend client-id) + (ui-close-result "Attention window shown.")) + ((%ui-lease-conflicts-only-p report) + (ui-replace-result + (append + (loop for choice in '((:partial "Open partial Activity and visit window" + "leave contested windows on their current Heads") + (:take "Move Activity windows here and visit" + "transfer contested windows from their current Heads")) + collect + (let ((chosen-policy (first choice))) + (make-ui-candidate + :id (list :attend-client client-id chosen-policy) + :label (second choice) :detail (third choice) :key-hint "Enter" + ;; Recheck target and lease before ANY activation. A + ;; cancelled/destroyed request must not switch tasks. + :action (lambda () (%ui-attend-client-result + backend client-id :policy chosen-policy))))) + (list (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" + :action (lambda () (ui-close-result))))) + "Resuming this Activity has lease conflicts. Choose explicitly.")) + (t (ui-keep-open-result (%ui-unresolvable-activation-detail report)))))))) + +(defun %ui-attention-candidates (backend) + (let ((world (x11-backend-world backend))) + (mapcar + (lambda (client-id) + (let* ((activity (find-activity world (client-activity-id (find-client world client-id)))) + (head-id (ewmh-active-head-id-for-client backend client-id))) + (make-ui-candidate + :id (list :attend-client client-id) + :label (format nil "~A: ~A" (activity-name activity) + (%ui-live-client-label backend client-id)) + :detail (if head-id + (format nil "focus on Head ~A; keep its lease there" head-id) + "open its Activity draft and show this window") + :key-hint "Enter" + :action (lambda () (%ui-attend-client-result backend client-id))))) + (backend-attention-client-ids backend)))) + +(defun %ui-attention-picker-result (backend) + (let ((candidates (%ui-attention-candidates backend))) + (if candidates + (ui-replace-result candidates "Windows needing attention; Enter visits, Esc leaves them alone.") + (ui-keep-open-result "No windows need attention.")))) + +(defun %ui-show-hidden-client-conflict-result (backend client-id) + "Ask before moving a hidden-picker client away from another Head." + (let* ((world (x11-backend-world backend)) + (lease (lease-for-client world client-id))) + (if (null lease) + ;; The other Head may have hidden it while this picker was open. The + ;; ordinary show operation is now safe and preserves the simple path. + (progn + (backend-show-client backend client-id) + (ui-close-result (format nil "Shown: ~A." + (%ui-client-label world client-id)))) + (let* ((source (find-presentation world (lease-presentation-id lease))) + (source-head-id (presentation-head-id source)) + (client-label (%ui-client-label world client-id))) + (ui-replace-result + (list + (make-ui-candidate + :id (list :take-hidden-client client-id) + :label (format nil "Move ~A here" client-label) + :detail (format nil "remove it from Head ~A's visible draft" + source-head-id) + :key-hint "Enter" + :action (lambda () + (backend-show-client-taking backend client-id) + (ui-close-result + (format nil "Moved here: ~A." client-label)))) + (make-ui-candidate + :id :cancel + :label "Cancel" + :detail "leave the window on its current Head" + :key-hint "Esc" + :action (lambda () (ui-close-result)))) + (format nil "~A is visible on Head ~A. Choose explicitly." + client-label source-head-id)))))) + +(defun %ui-hidden-client-candidates (backend) + "Search parked home/shared clients, including requested slots taken elsewhere." + (let* ((world (x11-backend-world backend)) + (presentation (current-presentation + world (x11-backend-focused-head-id backend)))) + (when presentation + (let ((activity (find-activity world (presentation-activity-id presentation)))) + (mapcar + (lambda (client-id) + (let* ((candidate-client-id client-id) + (client-label (%ui-live-client-label backend candidate-client-id)) + (client (find-client world candidate-client-id)) + (lease (lease-for-client world candidate-client-id)) + (detail + (if lease + (format nil "visible on Head ~A; choose whether to move it here" + (presentation-head-id + (find-presentation world + (lease-presentation-id lease)))) + (if (client-shared-p client) + (format nil "shared; home: ~A; show in ~A" + (activity-name (find-activity world (client-activity-id client))) + (activity-name activity)) + (format nil "hidden in Activity ~A" (activity-name activity)))))) + (make-ui-candidate + :id (list :show-hidden-client candidate-client-id) + :label (format nil "~A~AShow: ~A" + (if (backend-client-needs-attention-p backend candidate-client-id) + "! " "") + (if (client-shared-p client) "Shared · " "") client-label) + :detail detail + :key-hint "Enter" + :action + (lambda () + ;; Re-read the lease at execution time. A client may have + ;; moved during a palette session, and the transition choice + ;; must reflect the real current owner rather than stale text. + (if (lease-for-client (x11-backend-world backend) + candidate-client-id) + (%ui-show-hidden-client-conflict-result backend + candidate-client-id) + (progn + (backend-show-client backend candidate-client-id) + (ui-close-result + (format nil "Shown: ~A." client-label)))))))) + (%showable-client-ids world presentation)))))) + +(defun %ui-show-hidden-client-picker-result (backend) + "Return a search replacement for parked Activity clients, if any." + (let ((candidates (%ui-hidden-client-candidates backend))) + (if candidates + (ui-replace-result candidates + "Hidden and shared windows; Enter shows one.") + (ui-keep-open-result "No hidden or shared windows available on this Head.")))) + +(defun %ui-show-hidden-clients-candidate (backend) + "Return the direct-search entry for the focused Activity's parked clients." + (when (%ui-hidden-client-candidates backend) + (make-ui-candidate + :id :show-hidden-client + :label "Show hidden window..." + :detail "search this Activity's hidden windows and shared windows" + :key-hint "Enter" + :action (lambda () (%ui-show-hidden-client-picker-result backend))))) + +(defun %ui-hide-focused-client-candidate (backend) + "Return the direct-search hide action only when a visible focus exists." + (let* ((world (x11-backend-world backend)) + (presentation (current-presentation + world (x11-backend-focused-head-id backend))) + (client-id (and presentation (presentation-focus-client-id presentation)))) + (when (and client-id + (member client-id + (presentation-leased-client-ids world presentation) + :test #'equal)) + (let ((client-label (%ui-client-label world client-id))) + (make-ui-candidate + :id :hide-focused-client + :label (format nil "Hide focused window: ~A" client-label) + :detail "park it in this Activity without closing it" + :key-hint "Enter" + :action (lambda () + (backend-hide-focused-client backend) + (ui-close-result (format nil "Hidden: ~A." client-label)))))))) + +(defun %ui-send-context-valid-p (backend context) + (let* ((world (x11-backend-world backend)) + (head-id (getf context :head-id))) + (and (= (world-revision world) (getf context :revision)) + (equal head-id (x11-backend-focused-head-id backend)) + (let ((source (current-presentation world head-id)) + (target (current-presentation world (getf context :target-head-id)))) + (and source target + (equal (presentation-id source) (getf context :source-id)) + (equal (presentation-id target) (getf context :target-id)) + (equal (presentation-focus-client-id source) (getf context :client-id))))))) + +(defun %ui-request-client-send (backend target-head-id) + "Move and follow eligible windows; confirm an explicit private rehome first." + (let* ((world (x11-backend-world backend)) + (head-id (x11-backend-focused-head-id backend))) + (%head-for-id backend target-head-id) + (when (equal head-id target-head-id) + (return-from %ui-request-client-send (ui-close-result "No other monitor to send to."))) + (let* ((source (%current-presentation-or-error backend head-id)) + (target (%current-presentation-or-error backend target-head-id)) + (client-id (presentation-focus-client-id source))) + (unless client-id + (return-from %ui-request-client-send (ui-close-result "No focused window to send."))) + (%require-visible-client backend client-id head-id) + (when (client-available-in-activity-p world client-id (presentation-activity-id target)) + (backend-transfer-focused-client-to-head backend target-head-id :head-id head-id) + (return-from %ui-request-client-send (ui-close-result "Window sent to the next monitor."))) + (let* ((from (activity-name (find-activity world (presentation-activity-id source)))) + (to (activity-name (find-activity world (presentation-activity-id target)))) + (title (%ui-live-client-label backend client-id)) + (context (list :head-id head-id :target-head-id target-head-id + :source-id (presentation-id source) :target-id (presentation-id target) + :client-id client-id :revision (world-revision world))) + (detail (format nil "~A — leaves ~A's saved views; focus follows the window" title from))) + (ui-replace-result + (list + (make-ui-candidate :id :cancel :label "Cancel" :detail detail :key-hint "Esc" + :action (lambda () (ui-close-result))) + (make-ui-candidate + :id (list :confirm-send-client client-id target-head-id) + :label (format nil "Move to ~A" to) :detail detail :key-hint "Enter" + :action (lambda () + (if (%ui-send-context-valid-p backend context) + (progn + (backend-rehome-client-to-head + backend client-id target-head-id :head-id head-id + :expected-revision (getf context :revision)) + (ui-close-result (format nil "Window moved to ~A on the other monitor." to))) + (ui-keep-open-result "The desk changed. Cancel and try sending the window again."))))) + (format nil "Move this window from ~A to ~A? Select Move and Enter, or Esc to cancel." from to)))))) + +(defun backend-send-focused-client-to-head (backend target-head-id) + "Interactive Head send, confirming private cross-Activity membership changes." + (let ((result (%ui-request-client-send backend target-head-id))) + (unless (or (eq (ui-result-kind result) :close) + (backend-command-palette-open-p backend)) + (%open-ui-session backend (make-ui-session (ui-result-candidates result) + :status (ui-result-message result)))) + result)) + +(defun backend-send-focused-client-relatively (backend direction) + "Send toward the next/previous monitor through the shared confirmation UI." + (backend-send-focused-client-to-head + backend (%relative-head-id backend (x11-backend-focused-head-id backend) direction))) + +(defun %ui-move-client-result (backend client-id head-id) + (%require-visible-client backend client-id head-id) + (let* ((world (x11-backend-world backend)) + (source (%current-presentation-or-error backend head-id)) + (candidates + (loop for activity in (list-activities world) + unless (equal (activity-id activity) (presentation-activity-id source)) + collect + (let ((id (activity-id activity)) (name (activity-name activity))) + (make-ui-candidate + :id (list :move-client-to-activity client-id id) + :label (format nil "Move to: ~A" name) + :detail (if (eq :portable (backend-activity-navigation-mode backend id)) + "send to its current arrangement, wherever it is; keep focus here" + "queue in its portion on this monitor; keep focus here") + :key-hint "Enter" + :action (lambda () + (backend-move-client-to-activity backend client-id id :head-id head-id) + (ui-close-result (format nil "Window moved to ~A." name)))))))) + (if candidates + (ui-replace-result candidates "Choose destination Activity. Private windows leave old checkpoints; shared windows keep sharing.") + (ui-keep-open-result "Create another Activity first (a n).")))) + +(defun %ui-private-context-valid-p (backend context) + (let* ((world (x11-backend-world backend)) + (head-id (getf context :head-id))) + (and (= (world-revision world) (getf context :revision)) + (equal head-id (x11-backend-focused-head-id backend)) + (let ((p (current-presentation world head-id))) + (and p (equal (presentation-id p) (getf context :presentation-id)) + (equal (presentation-activity-id p) (getf context :activity-id)) + (equal (presentation-focus-client-id p) (getf context :client-id))))))) + +(defun %ui-set-client-sharing-result (backend client-id head-id shared-p) + (%require-visible-client backend client-id head-id) + (if shared-p + (progn + (backend-set-client-shared backend client-id t) + (ui-close-result "Window shared. Super-i can show it from any Activity.")) + (let* ((world (x11-backend-world backend)) + (p (current-presentation world head-id)) + (activity-id (presentation-activity-id p)) + (name (activity-name (find-activity world activity-id))) + (context (list :head-id head-id :presentation-id (presentation-id p) + :activity-id activity-id :client-id client-id :revision (world-revision world))) + (detail (format nil "Keep this window in ~A; remove it from other Activities and their saved views" name))) + (ui-replace-result + (list + (make-ui-candidate :id :cancel :label "Cancel" :detail detail :key-hint "Esc" + :action (lambda () (ui-close-result))) + (make-ui-candidate + :id (list :make-client-private client-id) :label (format nil "Make private to ~A" name) + :detail detail + :key-hint "Enter" + :action (lambda () + (if (%ui-private-context-valid-p backend context) + (progn + (backend-make-client-private backend client-id :head-id head-id + :expected-revision (getf context :revision)) + (ui-close-result (format nil "Window is now private to ~A." name))) + (ui-keep-open-result "The desk changed. Cancel and choose Make private again."))))) + (format nil "Make private to ~A? The window stays here, in the same position." name))))) + +(defun %ui-membership-candidates (backend) + (let* ((world (x11-backend-world backend)) + (head-id (x11-backend-focused-head-id backend)) + (p (current-presentation world head-id)) + (id (and p (presentation-focus-client-id p)))) + (when (and id (member id (presentation-leased-client-ids world p) :test #'equal)) + (let ((shared-p (client-shared-p (find-client world id)))) + ;; Capture the real window, not whichever one gains focus while a + ;; picker is open. Commands revalidate its lease before committing. + (list + (make-ui-candidate + :id :move-client-to-activity :label "Move window to Activity..." :key-hint "Enter" + :detail "change its home and queue it in the destination draft" + :action (lambda () (%ui-move-client-result backend id head-id))) + (make-ui-candidate + :id :set-client-shared + :label (if shared-p (format nil "Make private to ~A..." (activity-name (find-activity world (presentation-activity-id p)))) + "Make window shared") + :key-hint "Enter" :detail (if shared-p "keep here; remove other Activities' saved and live references" + "available everywhere, visible only where leased") + :action (lambda () (%ui-set-client-sharing-result backend id head-id (not shared-p))))))))) + +(defun %ui-view-update-context-valid-p (backend context) + "Do not overwrite a checkpoint using a different desk than was reviewed." + (let* ((world (x11-backend-world backend)) + (head-id (getf context :head-id))) + (and (= (world-revision world) (getf context :revision)) + (equal head-id (x11-backend-focused-head-id backend)) + (let ((p (current-presentation world head-id))) + (and p (equal (presentation-id p) (getf context :presentation-id))))))) + +(defun %ui-confirm-view-update-result (backend view-id context) + (unless (%ui-view-update-context-valid-p backend context) + (return-from %ui-confirm-view-update-result + (ui-keep-open-result "The arrangement changed. Cancel and choose the saved view again."))) + (let* ((world (x11-backend-world backend)) + (view (find-view world view-id)) + (name (view-name view)) + (activity-name (activity-name (find-activity world (view-activity-id view))))) + (ui-replace-result + (list + (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" + :action (lambda () (ui-close-result))) + (make-ui-candidate + :id (list :confirm-update-view view-id) + :label (format nil "Replace saved view: ~A" name) + :detail (format nil "overwrite this checkpoint in ~A; other saved views stay unchanged" activity-name) + :key-hint "Enter" + :action (lambda () + (if (%ui-view-update-context-valid-p backend context) + (progn + (backend-update-view backend view-id :head-id (getf context :head-id)) + (ui-close-result (format nil "Updated saved view: ~A." name))) + (ui-keep-open-result "The arrangement changed. Cancel and choose the saved view again."))))) + (format nil "Replace ~A / ~A with this monitor's current arrangement?" activity-name name)))) + +(defun %ui-view-update-picker-result (backend) + "Choose an explicit checkpoint target, including from an unsourced draft." + (let* ((world (x11-backend-world backend)) + (head-id (x11-backend-focused-head-id backend)) + (p (current-presentation world head-id)) + (view-ids (and p (activity-view-ids (find-activity world (presentation-activity-id p))))) + (context (list :head-id head-id :presentation-id (and p (presentation-id p)) + :revision (world-revision world)))) + (ui-replace-result + (loop for id in (sort (copy-list view-ids) #'< :key (lambda (id) (backend-view-slot backend id))) + collect (let ((view-id id)) + (make-ui-candidate + :id (list :update-view view-id) + :label (view-name (find-view world view-id)) + :detail "replace with the current arrangement; confirmation required" + :key-hint "Enter" + :action (lambda () (%ui-confirm-view-update-result backend view-id context))))) + (if view-ids + "Choose a saved view to replace with this monitor's arrangement." + "No saved views in this Activity. Save a new checkpoint first.")))) + +(defun %ui-update-current-view-candidate (backend) + (let* ((world (x11-backend-world backend)) + (p (current-presentation world (x11-backend-focused-head-id backend)))) + (when (and p (activity-view-ids (find-activity world (presentation-activity-id p)))) + (make-ui-candidate + :id :update-current-view + :label "Update saved view..." + :detail "choose a checkpoint to replace with this arrangement" + :key-hint "Enter" + :action (lambda () (%ui-view-update-picker-result backend)))))) + +(defun %ui-new-named-activity-result (backend) + "Return the name prompt used by every frontend entry for a new Activity." + (ui-prompt-result + "New Activity" + (lambda (name) + (let ((presentation (backend-start-named-activity backend name))) + (ui-close-result + (format nil "Started Activity: ~A" + (activity-name + (find-activity (x11-backend-world backend) + (presentation-activity-id presentation))))))))) + +(defun %ui-new-named-activity-candidate (backend) + "Return the command that begins a generic text prompt for a new Activity." + (make-ui-candidate + :id :new-named-activity + :label "New named Activity..." + :detail "start a blank task on this Head" + :key-hint "Enter" + :action + (lambda () + (%ui-new-named-activity-result backend)))) + +(defun %ui-run-shell-command-result (backend) + "Return a dmenu_run-like shell-command prompt for the current X session." + (ui-prompt-result + "Run command" + (lambda (command) + (backend-launch-shell-command backend command) + (ui-close-result (format nil "Launched: ~A" command))) + :message "Type a command; Enter to launch; Esc to cancel.")) + +(defun %ui-run-shell-command-candidate (backend) + "Offer direct shell launch without making the palette itself a shell." + (make-ui-candidate + :id :run-shell-command + :label "Run command..." + :detail "launch through /bin/sh -c on this X session" + :key-hint "Enter" + :action (lambda () (%ui-run-shell-command-result backend)))) + +(defun %ui-program-launch-candidates (backend) + "Build inert executable choices for the focused Head's PATH launcher. + +The program catalog is deliberately separate from the general Lime palette: +Super-p is for the fast, familiar app-launch path, whereas Super-y navigates +Activities, Views, Viewsets, and commands. A selected program is launched as +one argument-vector element, never reconstructed as shell syntax." + (mapcar + (lambda (program) + (let ((program-name program)) + (make-ui-candidate + :id (list :program program-name) + :label program-name + :detail (if (string-equal program-name "waterfox") + "Waterfox (normal profile)" + "PATH executable") + :key-hint "Enter" + :action (lambda () + ;; Use the same browser command as the menu and binding; + ;; normal desktop launching must not force a test profile. + (if (string-equal program-name "waterfox") + (backend-launch-browser backend) + (backend-launch-program backend (list program-name))) + (ui-close-result (format nil "Launched: ~A" program-name)))))) + (%path-program-names))) + +(defun %ui-launch-terminal-candidate (backend) + (make-ui-candidate + :id :launch-terminal + :label "Launch terminal" + :detail "st" + :key-hint "Enter" + :action (lambda () + (backend-launch-terminal backend) + (ui-close-result "Launched terminal.")))) + +(defun %ui-launch-browser-candidate (backend) + (make-ui-candidate + :id :launch-browser + :label "Launch browser" + :detail "Waterfox" + :key-hint "Enter" + :action (lambda () + (backend-launch-browser backend) + (ui-close-result "Launched browser.")))) + +(defun %ui-save-named-view-result (backend) + "Return the name prompt used by every frontend entry for a saved View." + (ui-prompt-result + "New View" + (lambda (name) + (let ((saved-presentation (backend-save-named-view backend name))) + (ui-close-result + (format nil "Saved View: ~A" + (view-name + (find-view (x11-backend-world backend) + (presentation-source-view-id saved-presentation))))))))) + +(defun %ui-save-named-view-candidate (backend) + "Return the command that prompts for a named checkpoint of the live draft." + (let ((presentation (current-presentation (x11-backend-world backend) + (x11-backend-focused-head-id backend)))) + (when presentation + (make-ui-candidate + :id :save-named-view + :label "Save current arrangement as View..." + :detail (format nil "checkpoint ~A" (presentation-activity-id presentation)) + :key-hint "Enter" + :action + (lambda () + (%ui-save-named-view-result backend)))))) + +;;;; Named whole-desk Viewsets +;;; +;;; Viewsets use the same renderer-neutral prompt and replacement-candidate +;;; protocol as one-Head Views. The difference is entirely in the core report: +;;; it has already considered all target Heads as one atomic outgoing group. + +(defun %ui-viewset-entry-label (world entry) + (let* ((view (find-view world (viewset-entry-view-id entry))) + (activity (find-activity world (view-activity-id view)))) + (format nil "~A -> ~A / ~A" + (viewset-entry-head-id entry) + (activity-name activity) + (view-name view)))) + +(defun %ui-viewset-detail (world viewset) + (format nil "~{~A~^; ~}" + (mapcar (lambda (entry) (%ui-viewset-entry-label world entry)) + (viewset-entries viewset)))) + +(defun %ui-viewset-conflicts-resolvable-p (report) + (every (lambda (conflict) + (eq (viewset-conflict-kind conflict) :client-leased)) + (viewset-report-conflicts report))) + +(defun %ui-viewset-unresolvable-detail (report) + (let ((kinds (remove-duplicates + (mapcar #'viewset-conflict-kind (viewset-report-conflicts report))))) + (format nil "cannot activate until its ~{~(~A~)~^ and ~} conflict is repaired" + kinds))) + +(defun %ui-viewset-collision-choice-candidates (backend viewset-id report) + (let ((conflict-count (length (viewset-report-conflicts report)))) + (list + (make-ui-candidate + :id (list :activate-viewset-partially viewset-id) + :label "Open partial Viewset" + :detail (format nil "leave ~D contested window~:P on its current Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-activate-viewset-partially backend viewset-id) + (ui-close-result "Viewset opened partially."))) + (make-ui-candidate + :id (list :activate-viewset-taking viewset-id) + :label "Take contested windows" + :detail (format nil "move ~D contested window~:P into its saved Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-activate-viewset-taking backend viewset-id) + (ui-close-result "Viewset opened; windows transferred."))) + (make-ui-candidate + :id :cancel + :label "Cancel" + :detail "leave every Head unchanged" + :key-hint "Esc" + :action (lambda () (ui-close-result)))))) + +(defun %ui-request-viewset-activation (backend viewset-id) + (let ((report (backend-preflight-viewset-activation backend viewset-id))) + (cond + ((viewset-report-ready-p report) + (backend-activate-viewset-strictly backend viewset-id) + (ui-close-result "Viewset opened.")) + ((%ui-viewset-conflicts-resolvable-p report) + (ui-replace-result + (%ui-viewset-collision-choice-candidates backend viewset-id report) + (format nil "This Viewset has ~D lease conflict~:P. Choose explicitly." + (length (viewset-report-conflicts report))))) + (t + ;; Two target Views wanting one client, or a View still mounted on an + ;; unselected Head, has no ethical partial/take shortcut. Tell the user + ;; rather than letting candidate ordering choose a winner. + (ui-close-result + (format nil "Viewset ~A" + (%ui-viewset-unresolvable-detail report))))))) + +(defun %ui-viewset-candidates (backend) + "Build direct-search candidates for every durable Viewset." + (let* ((world (x11-backend-world backend)) + (viewsets (sort (copy-list (list-viewsets world)) #'string-lessp + :key (lambda (viewset) + (string-downcase + (%ui-display-name (viewset-name viewset))))))) + (mapcar + (lambda (viewset) + (let ((viewset-id (viewset-id viewset))) + (make-ui-candidate + :id (list :viewset viewset-id) + :label (format nil "Viewset: ~A" (viewset-name viewset)) + :detail (%ui-viewset-detail world viewset) + :key-hint "Enter" + :action (lambda () (%ui-request-viewset-activation backend viewset-id))))) + viewsets))) + +(defun %ui-save-named-viewset-result (backend) + (ui-prompt-result + "New Viewset" + (lambda (name) + (let ((viewset (backend-save-named-viewset backend name))) + (ui-close-result (format nil "Saved Viewset: ~A" (viewset-name viewset))))))) + +(defun %ui-viewset-capture-available-p (backend) + (every (lambda (head-id) + (let ((presentation (current-presentation (x11-backend-world backend) + head-id))) + (and presentation (presentation-source-view-id presentation)))) + (x11-backend-head-ids backend))) + +(defun %ui-save-named-viewset-candidate (backend) + "Offer capture only when it faithfully references saved Views on all Heads." + (when (%ui-viewset-capture-available-p backend) + (make-ui-candidate + :id :save-named-viewset + :label "Save current Heads as Viewset..." + :detail "capture their mounted saved Views, not unsaved drafts" + :key-hint "Enter" + :action (lambda () (%ui-save-named-viewset-result backend))))) + +(defun %ui-collision-choice-candidates (backend view-id report) + "Turn an immutable collision report into the two explicit lease choices." + (let ((conflict-count (length (activation-report-conflicts report)))) + (list + (make-ui-candidate + :id (list :activate-partially view-id) + :label "Recall without busy windows" + :detail (format nil "leave ~D leased window~:P on its current Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-activate-view-partially backend view-id) + (ui-close-result "View recalled without busy windows."))) + (make-ui-candidate + :id (list :activate-taking view-id) + :label "Move windows here" + :detail (format nil "transfer ~D contested window~:P to this Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-activate-view-taking backend view-id) + (ui-close-result "Windows transferred and View recalled."))) + (make-ui-candidate + :id :cancel + :label "Cancel" + :detail "leave both Heads unchanged" + :key-hint "Esc" + :action (lambda () (ui-close-result)))))) + +(defun %ui-lease-conflicts-only-p (report) + "Whether REPORT's choices can honestly be resolved by lease policy. + +Partial and take are meaningful only for client leases. A View-mounted +conflict is structural: a saved single-Head View cannot be duplicated across +two Heads, so presenting a pretend transfer choice would be misleading." + (every (lambda (conflict) + (eq (activation-conflict-kind conflict) :client-leased)) + (activation-report-conflicts report))) + +(defun %ui-unresolvable-activation-detail (report) + "Return a direct explanation for a non-lease View activation conflict." + (let ((mounted-conflict + (find :view-mounted (activation-report-conflicts report) + :key #'activation-conflict-kind))) + (if mounted-conflict + (format nil "This View is already open on ~A. Choose another View for this Head." + (activation-conflict-holder-head-id mounted-conflict)) + "This View has a conflict that cannot be resolved by moving windows."))) + +(defun %ui-request-view-activation (backend view-id &key (recall-p nil)) + "Menu recalls restore checkpoints; repeated numbered selection stays put." + (let ((current (current-presentation (x11-backend-world backend) (x11-backend-focused-head-id backend)))) + (when (and (not recall-p) current (equal view-id (presentation-source-view-id current))) + (return-from %ui-request-view-activation (ui-close-result "View is already current.")))) + (let ((report (backend-preflight-view-activation backend view-id))) + (cond + ((activation-report-ready-p report) + (backend-activate-view-strictly backend view-id) + (ui-close-result "View recalled.")) + ((%ui-lease-conflicts-only-p report) + (ui-replace-result + (%ui-collision-choice-candidates backend view-id report) + (format nil "This View has ~D lease conflict~:P. Choose explicitly." + (length (activation-report-conflicts report))))) + (t + (ui-keep-open-result (%ui-unresolvable-activation-detail report)))))) + +(defun %ui-activity-collision-choice-candidates (backend activity-id report) + "Offer explicit lease choices when resuming an Activity draft collides." + (let ((conflict-count (length (activation-report-conflicts report)))) + (list + (make-ui-candidate + :id (list :activate-activity-partially activity-id) + :label "Open partial Activity" + :detail (format nil "leave ~D leased window~:P on its current Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-switch-to-activity backend activity-id :policy :partial) + (ui-close-result "Activity arrangement opened partially."))) + (make-ui-candidate + :id (list :activate-activity-taking activity-id) + :label "Move windows here" + :detail (format nil "transfer ~D contested window~:P to this Head" + conflict-count) + :key-hint "Enter" + :action (lambda () + (backend-switch-to-activity backend activity-id :policy :take) + (ui-close-result "Activity arrangement opened; windows transferred."))) + (make-ui-candidate + :id :cancel + :label "Cancel" + :detail "leave both Heads unchanged" + :key-hint "Esc" + :action (lambda () (ui-close-result)))))) + +(defun %ui-request-activity-activation (backend activity-id) + "Bring a portable Activity here or resume this monitor's extended portion." + ;; Activity navigation resumes current locations; only an explicit saved + ;; View recall requests historical locations and offers lease choices. + (backend-switch-to-activity backend activity-id) + (ui-close-result "Activity opened.")) + +;;;; RandR topology-reconciliation flow +;;; +;;; The generic UI session already knows how to replace one candidate list with +;;; another. A display change is therefore a normal palette flow: inspect an +;;; immutable report, collect explicit routing choices, then apply one plan. +;;; No RandR event itself opens this UI or moves a client. + +(defun %ui-randr-topology-changed-p (report) + (and report + (or (head-topology-report-added-head-ids report) + (head-topology-report-removed-head-ids report)))) + +(defun %ui-randr-pending-snapshot (backend) + "Return a pending migration snapshot suitable for a palette, or NIL. + +Explicitly configured Heads have no RandR migration contract. A same-id +geometry refresh also does not need an interactive routing decision." + (when (and (eq (x11-backend-head-source backend) :randr) + (x11-backend-randr-topology-dirty-p backend)) + (handler-case + (let* ((snapshot (backend-randr-topology-report backend)) + (report (getf snapshot :report))) + (and (%ui-randr-topology-changed-p report) snapshot)) + (invalid-transition () nil)))) + +(defun %ui-randr-change-detail (report) + (format nil "~D Head~:P added; ~D Head~:P removed" + (length (head-topology-report-added-head-ids report)) + (length (head-topology-report-removed-head-ids report)))) + +(defun %ui-randr-source-label (world source) + "Make one removed Presentation understandable without leaking raw ids first." + (let* ((activity (find-activity world (head-topology-source-activity-id source))) + (source-view-id (head-topology-source-source-view-id source)) + (view-name + (and source-view-id + (handler-case + (view-name (find-view world source-view-id)) + (unknown-entity () nil))))) + (format nil "~A / ~A from ~A" + (activity-name activity) + (or view-name "unsaved draft") + (head-topology-source-head-id source)))) + +(defun %ui-randr-plan-detail (report moves) + "Describe both explicit moves and intentionally suspended live drafts." + (let* ((moved-source-head-ids + (mapcar #'head-topology-move-from-head-id moves)) + (suspended-source-head-ids + (remove-if (lambda (head-id) + (member head-id moved-source-head-ids :test #'equal)) + (mapcar #'head-topology-source-head-id + (head-topology-report-removed-active-sources report)))) + (choices + (append + (mapcar (lambda (move) + (format nil "~A -> ~A" + (head-topology-move-from-head-id move) + (head-topology-move-to-head-id move))) + moves) + (mapcar (lambda (head-id) + (format nil "~A suspended" head-id)) + suspended-source-head-ids)))) + (if choices + (format nil "~{~A~^; ~}" choices) + "no live Presentation moves"))) + +(defun %ui-randr-apply-result (backend moves) + "Build and apply the choices collected by the palette in one final action." + (let* ((plan (backend-build-randr-topology-plan backend :moves moves)) + (result (backend-apply-randr-topology-plan backend plan))) + (ui-close-result + (format nil "Displays reconciled: ~D moved; ~D suspended." + (length (head-topology-result-moved-presentation-ids result)) + (length (head-topology-result-suspended-presentation-ids result)))))) + +(defun %ui-randr-final-candidates (backend report moves) + "Return the final review/apply choice after all removed sources are decided." + (list + (make-ui-candidate + :id (list :apply-randr-topology moves) + :label "Apply display plan" + :detail (%ui-randr-plan-detail report moves) + :key-hint "Enter" + :action (lambda () (%ui-randr-apply-result backend moves))) + (make-ui-candidate + :id :cancel-randr-topology + :label "Cancel" + :detail "leave Activities, Views, and leases unchanged" + :key-hint "Esc" + :action (lambda () (ui-close-result))))) + +(defun %ui-randr-next-source-result (backend report remaining-sources moves) + "Ask about the next removed source, or present the final apply choice." + (if (null remaining-sources) + (ui-replace-result + (%ui-randr-final-candidates backend report moves) + (format nil "Display plan ready: ~A." + (%ui-randr-plan-detail report moves))) + (let* ((source (first remaining-sources)) + (world (x11-backend-world backend)) + (used-destination-head-ids + (mapcar #'head-topology-move-to-head-id moves)) + (destination-head-ids + (remove-if (lambda (head-id) + (member head-id used-destination-head-ids :test #'equal)) + (head-topology-report-desired-head-ids report))) + (later-sources (rest remaining-sources)) + (source-label (%ui-randr-source-label world source))) + (ui-replace-result + (append + (mapcar + (lambda (destination-head-id) + (let ((destination destination-head-id)) + (make-ui-candidate + :id (list :move-randr-source + (head-topology-source-head-id source) destination) + :label (format nil "Move to ~A" destination) + :detail (format nil "show ~A there" source-label) + :key-hint "Enter" + :action + (lambda () + (%ui-randr-next-source-result + backend report later-sources + (append moves + (list (make-head-topology-move + :from-head-id + (head-topology-source-head-id source) + :to-head-id destination)))))))) + destination-head-ids) + (list + (make-ui-candidate + :id (list :suspend-randr-source (head-topology-source-head-id source)) + :label "Suspend safely" + :detail (format nil "keep ~A as a lease-free cached draft" source-label) + :key-hint "Enter" + :action (lambda () + (%ui-randr-next-source-result + backend report later-sources moves))) + (make-ui-candidate + :id :cancel-randr-topology + :label "Cancel" + :detail "leave Activities, Views, and leases unchanged" + :key-hint "Esc" + :action (lambda () (ui-close-result))))) + (format nil "Where should ~A go?" source-label))))) + +(defun %ui-randr-topology-result (backend) + "Begin a fresh interactive reconciliation, or explain why none is pending." + (let ((snapshot (%ui-randr-pending-snapshot backend))) + (if snapshot + (let ((report (getf snapshot :report))) + (%ui-randr-next-source-result + backend report (head-topology-report-removed-active-sources report) '())) + (ui-close-result "No display topology reconciliation is pending.")))) + +(defun %ui-randr-topology-candidate (backend) + "Expose a pending display change in direct palette search without nagging." + (let ((snapshot (%ui-randr-pending-snapshot backend))) + (when snapshot + (let ((report (getf snapshot :report))) + (make-ui-candidate + :id :reconcile-randr-topology + :label "Reconcile changed displays..." + :detail (%ui-randr-change-detail report) + :key-hint "Enter" + :action (lambda () (%ui-randr-topology-result backend))))))) + +(defun %ui-quit-lime-candidate (backend) + "Return the explicit graceful shutdown command shared by palette surfaces." + (make-ui-candidate + :id :quit-lime + :label "Quit Lime" + :detail "release the X session cleanly and remap managed windows" + :key-hint "Enter" + :action (lambda () + (backend-request-quit backend) + (ui-close-result "Lime is quitting.")))) + +(defun %command-palette-candidates (backend) + (let ((update-candidate (%ui-update-current-view-candidate backend)) + (randr-candidate (%ui-randr-topology-candidate backend)) + (save-viewset-candidate (%ui-save-named-viewset-candidate backend)) + (show-hidden-candidate (%ui-show-hidden-clients-candidate backend)) + (hide-focused-candidate (%ui-hide-focused-client-candidate backend))) + (append (when randr-candidate (list randr-candidate)) + (list (%ui-quit-lime-candidate backend)) + (list (make-ui-candidate + :id :attention :label "Windows needing attention..." + :detail "requests across all Activities" :key-hint "Enter" + :action (lambda () (%ui-attention-picker-result backend)))) + (when show-hidden-candidate (list show-hidden-candidate)) + (when hide-focused-candidate (list hide-focused-candidate)) + (%ui-membership-candidates backend) + (list (%ui-run-shell-command-candidate backend) + (%ui-launch-terminal-candidate backend) + (%ui-launch-browser-candidate backend)) + (list (%ui-new-named-activity-candidate backend) + (make-ui-candidate + :id :delete-activity :label "Delete Activity..." :key-hint "Enter" + :detail "remove an empty, unmounted Activity and its saved arrangements" + :action (lambda () (%ui-delete-activity-picker-result backend)))) + (%ui-activity-monitor-candidates backend) + (let ((save-candidate (%ui-save-named-view-candidate backend))) + (when save-candidate (list save-candidate))) + (when save-viewset-candidate (list save-viewset-candidate)) + (when update-candidate (list update-candidate)) + (%ui-viewset-candidates backend) + (%ui-activity-candidates backend) + ;; User-defined commands are one registry shared by bindings and + ;; direct search; the palette does not need a parallel command + ;; implementation or a special case for config files. + (configuration-command-candidates backend)))) + +(defun %ui-view-candidates (backend) + "Return just the saved View choices from the palette's durable catalog." + (remove-if-not (lambda (candidate) + (eq (first (ui-candidate-id candidate)) :view)) + (%ui-activity-candidates backend))) + +(defun %ui-command-result (command success-message) + "Run one imperative command and request a palette close after success." + (funcall command) + (ui-close-result success-message)) + +(defun %ui-key-path (backend) + "Build the X11 frontend's available which-key-style command tree. + +The tree only names command-layer operations. Its navigation, parent handling, +and text prompting belong to LIME.UI, so another renderer can provide a +different tree without modifying session mechanics." + (flet ((node (id key label detail &key action children) + (make-ui-key-node :id id :key key :label label :detail detail + :action action :children children)) + (command (success-message function) + (lambda () (%ui-command-result function success-message)))) + (let ((view-entries + (list + (node :save-view #\s "Save checkpoint..." + "prompt for a checkpoint name" + :action (lambda () (%ui-save-named-view-result backend))) + (node :open-view #\o "Recall view..." + "apply a saved arrangement" + :action (lambda () + (ui-replace-result (%ui-view-candidates backend) + "Choose a saved arrangement to recall on this monitor."))))) + (activity-entries + (list + (node :delete-activity #\d "Delete activity..." + "choose an empty, unmounted Activity; confirmation required" + :action (lambda () (%ui-delete-activity-picker-result backend))) + (node :new-activity #\n "New activity..." + "prompt for a blank task name" + :action (lambda () (%ui-new-named-activity-result backend))) + (node :open-activity #\o "Find activity / saved view..." + "resume an Activity or recall a checkpoint" + :action (lambda () + (ui-replace-result (%ui-activity-candidates backend) + "Type to filter Activities and Views."))) + (node :extend-activity #\e "Extend to monitor..." + "open another portion of this Activity without moving its windows" + :action (lambda () (%ui-extend-activity-result backend))) + (node :portable-activity #\p "Use one monitor..." + "make this arrangement portable once the other portions are empty" + :action (lambda () (%ui-portable-activity-result backend)))))) + (when (%ui-update-current-view-candidate backend) + (setf view-entries + (append view-entries + (list + (node :update-view #\u "Update saved view..." + "choose a checkpoint to replace" + :action (lambda () (%ui-view-update-picker-result backend))))))) + (append + (list + (node :activity #\a "Activities" "start, open, or delete a task" + :children activity-entries) + (node :launch #\r "Launch" "start an application in this X session" + :children + (list + (node :run-command #\r "Run command..." + "prompt for a shell command" + :action (lambda () (%ui-run-shell-command-result backend))) + (node :launch-terminal #\t "Launch terminal" "st" + :action (command "Launched terminal." + (lambda () (backend-launch-terminal backend)))) + (node :launch-browser #\b "Launch browser" "Waterfox" + :action (command "Launched browser." + (lambda () (backend-launch-browser backend)))))) + (node :view #\v "Saved views" "recall, save, or replace arrangements" + :children view-entries) + (node :viewset #\x "Viewsets" "save or atomically open several Views" + :children + (append + (list + (node :open-viewset #\o "Open Viewset..." + "search saved multi-Head shortcuts" + :action (lambda () + (ui-replace-result (%ui-viewset-candidates backend) + "Type to filter Viewsets.")))) + (when (%ui-viewset-capture-available-p backend) + (list + (node :save-viewset #\s "Save viewset..." + "prompt for a multi-Head shortcut name" + :action (lambda () (%ui-save-named-viewset-result backend))))))) + (node :layout #\l "Layout" "change the active Head's layout" + :children + (list + (node :master-stack #\m "Master/stack" "use the built-in master layout" + :action (command "Master/stack layout selected." + (lambda () (backend-use-master-stack-layout backend)))) + (node :monocle #\o "Monocle" "show the focused tiled client" + :action (command "Monocle layout selected." + (lambda () (backend-use-monocle-layout backend)))) + (node :cycle #\c "Cycle layout" "master/stack, monocle" + :action (command "Layout cycled." + (lambda () (backend-cycle-layout backend)))))) + (node :window #\w "Windows" "focus, show, hide, float, or close clients" + :children + (append + (loop for candidate in (%ui-membership-candidates backend) + for key in '(#\m #\s) + collect (node (ui-candidate-id candidate) key + (ui-candidate-label candidate) (ui-candidate-detail candidate) + :action (ui-candidate-action candidate))) + (list + (node :attention #\a "Attention..." "requests across all Activities" + :action (lambda () (%ui-attention-picker-result backend))) + (node :focus-next #\n "Focus next" "next visible client" + :action (command "Focused next client." + (lambda () (backend-focus-next-client backend)))) + (node :focus-previous #\p "Focus previous" "previous visible client" + :action (command "Focused previous client." + (lambda () (backend-focus-previous-client backend)))) + (node :toggle-float #\f "Toggle float" "toggle the focused client's placement" + :action (command "Toggled floating placement." + (lambda () (backend-toggle-focused-client-floating backend)))) + (node :hide-focused-client #\h "Hide focused window" + "park it in this Activity without closing it" + :action (command "Focused window hidden." + (lambda () (backend-hide-focused-client backend)))) + (node :show-hidden-client #\i "Show hidden window..." + "search hidden Activity windows and shared windows" + :action (lambda () + (%ui-show-hidden-client-picker-result backend))) + (node :close #\c "Close focused client" "request WM_DELETE_WINDOW or kill" + :action (command "Close requested." + (lambda () (backend-close-focused-client backend))))))) + (node :head #\h "Heads" "select a Head or transfer an eligible window" + :children + (append + (list + (node :next-head #\n "Select next Head" "move command focus" + :action (command "Selected next Head." + (lambda () (backend-select-relative-head backend :next)))) + (node :previous-head #\p "Select previous Head" "move command focus" + :action (command "Selected previous Head." + (lambda () (backend-select-relative-head backend :previous)))) + (node :send-next-head #\s "Send client to next Head" + "send the window; confirm if its Activity would change" + :action (lambda () (backend-send-focused-client-relatively backend :next)))) + (when (%ui-randr-topology-candidate backend) + (list + (node :reconcile-randr-topology #\t "Reconcile changed displays..." + "choose where removed Heads' live drafts go" + :action (lambda () (%ui-randr-topology-result backend)))))))) + (list + (node :system #\q "System" "session-level Lime commands" + :children + (list + (node :quit-lime #\q "Quit Lime" + "release the X session cleanly and remap managed windows" + :action (command "Lime is quitting." + (lambda () (backend-request-quit backend))))))) + (let ((configured-nodes (configuration-command-key-nodes backend))) + (when configured-nodes + (list + (node :user-commands #\u "User" "commands from your Lisp configuration" + :children configured-nodes)))))))) + + +(defun %open-ui-session (backend session) + "Display SESSION in a focused Head-local overlay and return BACKEND. + +The overlay is an override-redirect X11 child owned by Lime, never a managed +client. It grabs the keyboard only while visible; the renderer-neutral SESSION +decides whether this is a direct prompt, searchable palette, or key-path menu." + (unless (backend-command-palette-open-p backend) + (let* ((head-id (x11-backend-focused-head-id backend)) + (overlay (%make-ui-overlay backend head-id session))) + (unwind-protect + (progn + (setf (x11-backend-ui-session backend) session + (x11-backend-ui-overlay backend) overlay) + (xlib:map-window (x11-ui-overlay-window overlay)) + (xlib:display-force-output (x11-backend-display backend)) + (unless (eq (xlib:grab-keyboard (x11-ui-overlay-window overlay) + :owner-p t) + :success) + (error 'invalid-transition + :description "Lime could not grab the keyboard for its command palette.")) + (%render-command-palette backend) + (setf overlay nil)) + (when overlay + (setf (x11-backend-ui-session backend) nil + (x11-backend-ui-overlay backend) nil) + (%free-ui-overlay overlay))))) + backend) + +(defun %make-command-menu-session (backend) + "Build the shared Super-y / bar-logo command map without touching X11." + (make-ui-session (%command-palette-candidates backend) + :key-path (%ui-key-path backend) :mode :key-path)) + +(defun backend-open-command-palette (backend) + "Open the focused Head's which-key command map and return BACKEND." + (%open-ui-session + backend + (%make-command-menu-session backend))) + +(defun backend-open-activity-picker (backend) + "Open an Activity-only picker, shared by bar overflow and custom bindings." + (%open-ui-session + backend + (make-ui-session + (sort (remove-if-not (lambda (candidate) (eq :activity (first (ui-candidate-id candidate)))) + (%ui-activity-candidates backend)) + #'< :key (lambda (candidate) (backend-activity-slot backend (second (ui-candidate-id candidate))))) + :status "Choose an Activity for this Head; Enter switches, Esc cancels."))) + +(defun backend-open-run-prompt (backend) + "Open a dmenu_run-like PATH program picker on the focused Head. + +The picker starts with executable candidates instead of a blank shell prompt, +then filters them with the renderer-neutral ordered fuzzy matcher. Raw shell +input remains explicit under the richer command palette for commands with +arguments, redirections, aliases, or other shell syntax." + (%open-ui-session + backend + (make-ui-session + (%ui-program-launch-candidates backend) + :status "Type to fuzzy-search PATH programs; Enter launches; Esc cancels."))) + +(defun backend-open-hidden-client-picker (backend) + "Open a focused-Activity fuzzy picker for currently parked windows." + (let ((candidates (%ui-hidden-client-candidates backend))) + (unless candidates + (error 'invalid-transition + :description "No hidden or shared windows are available on this Head.")) + (%open-ui-session + backend + (make-ui-session candidates + :status "Hidden and shared windows; Enter shows one.")))) + +(defun backend-open-attention-picker (backend) + "Open a searchable list of requesting windows across every Activity." + (%open-ui-session + backend (make-ui-session (%ui-attention-candidates backend) + :status "Windows needing attention; Enter visits, Esc cancels."))) + +(defun backend-open-view-update-picker (backend) + "Choose and confirm a saved arrangement to replace; never infer the target." + (let ((result (%ui-view-update-picker-result backend))) + ;; Configured commands are also searchable inside the existing palette. + ;; Return its next transition there instead of opening a second overlay. + (if (backend-command-palette-open-p backend) + result + (%open-ui-session backend + (make-ui-session (ui-result-candidates result) + :status (ui-result-message result)))))) + +(defun backend-close-command-palette (backend &key (acknowledge-p t)) + "Close the palette, release its temporary keyboard grab, and return BACKEND." + (let ((overlay (x11-backend-ui-overlay backend)) + (display (x11-backend-display backend))) + (setf (x11-backend-ui-session backend) nil + (x11-backend-ui-overlay backend) nil) + (when display + (xlib:ungrab-keyboard display) + (%free-ui-overlay overlay) + (when acknowledge-p + (%attention-acknowledge-selected backend) + (render-head-bars backend)) + (xlib:display-force-output display))) + backend) + +(defun %ui-event-key (backend keycode state) + "Translate a CLX KeyPress into the small renderer-neutral session alphabet." + (let ((keysym (xlib:keycode->keysym (x11-backend-display backend) keycode 0))) + (cond ((= keysym #xFF1B) :escape) + ((= keysym #xFF09) :tab) + ((= keysym #xFF0D) :return) + ((= keysym #xFF08) :backspace) + ((= keysym #xFF52) :up) + ((= keysym #xFF54) :down) + ((= keysym #xFF55) :page-up) + ((= keysym #xFF56) :page-down) + (t (xlib:keysym->character (x11-backend-display backend) keysym state))))) + +(defun %perform-ui-action (backend action) + "Run keyboard and pointer actions through one transition/error boundary." + (let ((session (x11-backend-ui-session backend))) + (when session + (handler-case + (progn + (setf (x11-ui-overlay-hovered-action (x11-backend-ui-overlay backend)) nil) + (let ((result (ecase (first action) + (:key (ui-session-handle-key session (second action))) + (:key-event (ui-session-handle-key + session (%ui-event-key backend (second action) (third action)))) + (:candidate (ui-session-activate-candidate session (second action)))))) + (if (eq (ui-result-kind result) :close) + (backend-close-command-palette backend) + (%render-command-palette backend)))) + (error (condition) + ;; UI errors should never escape into the event loop. They are still + ;; inspectable through the existing backend error slot and visible in + ;; the palette's status line. + (setf (x11-backend-last-command-error backend) condition + (ui-session-status session) (princ-to-string condition)) + (%render-command-palette backend)))) + nil)) + +(defun %handle-ui-key-press (backend keycode state) + "Route one grabbed key through the renderer-neutral palette session." + (%perform-ui-action backend (list :key-event keycode state))) + +(defun %refresh-ui-cursors (backend) + "Rebind even an unchanged hover role when configuration replaces its XID." + (maphash (lambda (head-id bar) + (declare (ignore head-id)) + (setf (xlib:window-cursor (x11-head-bar-window bar)) + (if (x11-head-bar-pointer-hand-p bar) (x11-backend-hand-cursor backend) :none))) + (x11-backend-head-bars backend)) + (let ((overlay (x11-backend-ui-overlay backend))) + (when overlay + (setf (xlib:window-cursor (x11-ui-overlay-window overlay)) + (if (x11-ui-overlay-pointer-hand-p overlay) (x11-backend-hand-cursor backend) :none))))) + +(defun %ui-event-overlay (backend window) + (let ((overlay (x11-backend-ui-overlay backend))) + (when (and overlay window + (= (xlib:window-id window) (xlib:window-id (x11-ui-overlay-window overlay)))) + overlay))) + +(defun %ui-root-hit (overlay root-x root-y) + (let ((window (x11-ui-overlay-window overlay))) + (%ui-hit-at overlay (- root-x (xlib:drawable-x window)) + (- root-y (xlib:drawable-y window))))) + +(defun %handle-ui-button-press (backend window root-x root-y button) + "Consume overlay clicks before the WM's client-focus/drag machinery." + (let ((overlay (%ui-event-overlay backend window))) + (when overlay + (case button + (1 (let ((hit (%ui-root-hit overlay root-x root-y))) + (when hit (%perform-ui-action backend (ui-hit-region-action hit))))) + ((4 5) + (let* ((session (x11-backend-ui-session backend)) + (key (case (ui-session-mode session) + (:key-path (if (= button 4) :page-up :page-down)) + (:search (if (= button 4) :up :down))))) + (when key (%perform-ui-action backend (list :key key)))))) + ;; Even a click in blank space belongs to the menu, never the desktop. + t))) + +(defun %handle-ui-motion (backend window root-x root-y) + (let ((overlay (%ui-event-overlay backend window))) + (when overlay + (let* ((hit (%ui-root-hit overlay root-x root-y)) + (action (and hit (ui-hit-region-action hit)))) + (unless (equal action (x11-ui-overlay-hovered-action overlay)) + (setf (x11-ui-overlay-hovered-action overlay) action) + (%render-command-palette backend))) + t))) + +(defun %handle-ui-leave (backend window) + (let ((overlay (%ui-event-overlay backend window))) + (when (and overlay (x11-ui-overlay-hovered-action overlay)) + (setf (x11-ui-overlay-hovered-action overlay) nil) + (%render-command-palette backend)))) + +(defun %handle-ui-exposure (backend window count) + "Redraw an exposed palette only after the final coalesced expose event." + (let ((overlay (x11-backend-ui-overlay backend))) + (when (and overlay (zerop count) + (= (xlib:window-id window) + (xlib:window-id (x11-ui-overlay-window overlay)))) + (%render-command-palette backend))) + nil) diff --git a/test/config-fixture.lisp b/test/config-fixture.lisp new file mode 100644 index 0000000..ed92cc9 --- /dev/null +++ b/test/config-fixture.lisp @@ -0,0 +1,12 @@ +(in-package #:lime.x11.test) + +;; This intentionally has no :OPTIONS clause: loading it proves that the DSL +;; supplies its documented Super default without requiring a full X server. +(lime.config:defconfiguration config-file-fixture + (:command reload + :label "Reload config" + :description "reload the test configuration" + :key #\r + :action (lambda (backend) + (declare (ignore backend)) + :reloaded))) diff --git a/test/development-package.lisp b/test/development-package.lisp new file mode 100644 index 0000000..909222b --- /dev/null +++ b/test/development-package.lisp @@ -0,0 +1,3 @@ +(defpackage #:lime.dev.test + (:use #:cl #:fiveam #:lime.dev) + (:export #:run-tests)) diff --git a/test/development.lisp b/test/development.lisp new file mode 100644 index 0000000..a57f70e --- /dev/null +++ b/test/development.lisp @@ -0,0 +1,54 @@ +(in-package #:lime.dev.test) + +(def-suite lime-dev-suite + :description "Developer runtime mailbox and reload-boundary tests.") + +(in-suite lime-dev-suite) + +(test only-ordinary-lime-systems-are-hot-reloadable + (is-true (lime.dev::%reloadable-development-system-p "lime")) + (is-true (lime.dev::%reloadable-development-system-p :lime/x11)) + (is-false (lime.dev::%reloadable-development-system-p "lime/dev")) + (is-false (lime.dev::%reloadable-development-system-p "unrelated"))) + +(test developer-start-arguments-do-not-leak-into-start-lime + (is (equal (lime.dev::%plist-without + '(:display-name ":5" :repl-port 4444 :start-repl-p nil + :event-timeout 0.02 :diagnostic-file nil :config-file "/tmp/lime-config.lisp") + '(:repl-port :start-repl-p :event-timeout :diagnostic-file)) + '(:display-name ":5" :config-file "/tmp/lime-config.lisp")))) + +(test supervision-retains-paused-and-restarting-sessions + (let ((session (lime.dev::%make-development-session :running-p t :paused-p t))) + (is-true (lime.dev::%development-supervised-p session)) + (setf (lime.dev::development-session-running-p session) nil + (lime.dev::development-session-restarting-p session) t) + (is-true (lime.dev::%development-supervised-p session)) + (setf (lime.dev::development-session-restarting-p session) nil) + (is-false (lime.dev::%development-supervised-p session)) + (is-false (lime.dev::%development-supervised-p nil)))) + +(test paused-mailbox-can-inspect-and-fail-without-losing-the-session + (let* ((session (lime.dev::%make-development-session :backend :fake :running-p t :paused-p t)) + (bad (lime.dev::make-development-request :function (lambda (backend) + (declare (ignore backend)) (error "Nope"))))) + (lime.dev::%enqueue-development-request session bad) + (lime.dev::%service-development-requests session :fake) + (is-true (lime.dev::development-request-completed-p bad)) + (is (typep (lime.dev::development-request-failure bad) 'error)) + (is-true (lime.dev::development-session-running-p session)) + (is-true (lime.dev::development-session-paused-p session)))) + +(test developer-mailbox-completes-work-on-its-owner-boundary + (let* ((session (lime.dev::%make-development-session :backend :fake :running-p t)) + (request (lime.dev::make-development-request + :function (lambda (backend) (list :backend backend))))) + (lime.dev::%enqueue-development-request session request) + (lime.dev::%service-development-requests session :fake) + (is-true (lime.dev::development-request-completed-p request)) + (is (equal (lime.dev::development-request-values request) + '((:backend :fake)))) + (is-false (lime.dev::development-request-failure request)))) + +(defun run-tests () + (run! 'lime-dev-suite)) diff --git a/test/gtk-cursor-probe.py b/test/gtk-cursor-probe.py new file mode 100644 index 0000000..f7f82fe --- /dev/null +++ b/test/gtk-cursor-probe.py @@ -0,0 +1,30 @@ +"""Test-only GTK client: query live settings over stdin on an owned X server.""" +import sys +import gi + +gi.require_version("Gtk", "3.0") +from gi.repository import Gtk, GLib + +Gtk.init([]) +settings = Gtk.Settings.get_default() +properties = ("gtk-cursor-theme-name", "gtk-cursor-theme-size", "gtk-theme-name", + "gtk-icon-theme-name", "gtk-font-name") + + +def reply(): + print("|".join(str(settings.get_property(name)) for name in properties), flush=True) + return False + + +def request(source, condition): + if not sys.stdin.readline(): + Gtk.main_quit() + return False + # Give queued X notifications a chance to dispatch before answering. + GLib.timeout_add(20, reply) + return True + + +GLib.io_add_watch(sys.stdin, GLib.IO_IN | GLib.IO_HUP, request) +reply() +Gtk.main() diff --git a/test/membership.lisp b/test/membership.lisp new file mode 100644 index 0000000..dba295b --- /dev/null +++ b/test/membership.lisp @@ -0,0 +1,422 @@ +(in-package #:lime.test) +(in-suite lime-suite) + +(test explicit-active-membership-move-is-one-transaction-and-keeps-both-desks + (dolist (mode '(:manual :master-stack :monocle)) + (dolist (floating-p '(nil t)) + (let* ((world (make-fixture)) + (source (activate-view-strictly world "left" "code")) + (target (activate-view-strictly world "right" "play"))) + (set-presentation-layout-mode world (presentation-id target) mode) + (when floating-p + (toggle-client-floating world (presentation-id source) "emacs" + :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))) + (let ((revision (world-revision world)) + (old-lease (lease-for-client world "game-client"))) + (move-client-to-presentation world "emacs" (presentation-id target) + :tiled-insertion-position :front) + (is (= (1+ revision) (world-revision world))) + (is (eq source (current-presentation world "left"))) + (is (eq target (current-presentation world "right"))) + (is (equal "game" (client-activity-id (find-client world "emacs")))) + (is (equal "right" (lease-head-id world "emacs"))) + (is (eq old-lease (lease-for-client world "game-client"))) + (is (equal "terminal" (presentation-focus-client-id source))) + (is (equal "emacs" (presentation-focus-client-id target))) + (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "code"))))) + (is (equal '("firefox") (mapcar #'placement-client-id (view-placements (find-view world "docs"))))) + (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "play"))))) + (is (presentation-dirty-p source)) + (is (presentation-dirty-p target)) + (is (eq mode (presentation-layout-mode target))) + (let ((placement (find "emacs" (presentation-placements target) :key #'placement-client-id :test #'equal))) + (is (eq (if floating-p :float :tile) (placement-kind placement))) + (when floating-p + (is (equal '(:x 1/4 :y 1/4 :width 1/2 :height 1/2) (placement-data placement))))) + (is (validate-world world))))))) + +(test explicit-live-move-failures-leave-membership-placements-and-lease-unchanged + (let* ((world (make-fixture)) + (source (activate-view-strictly world "left" "code")) + (target (activate-view-strictly world "right" "play")) + (revision (world-revision world)) + (lease (lease-for-client world "emacs")) + (source-placements (presentation-placements source)) + (target-placements (presentation-placements target))) + ;; The old parked-move command still rejects an active destination. + (signals invalid-transition (move-client-to-activity world "emacs" "game" :target-head-id "right")) + (signals error (move-client-to-presentation world "emacs" (presentation-id target) + :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy")))) + (signals invalid-transition (move-client-to-presentation world "emacs" (presentation-id target) + :tiled-insertion-position :invalid)) + (signals unknown-entity (move-client-to-presentation world "emacs" "missing")) + (is (= revision (world-revision world))) + (is (eq lease (lease-for-client world "emacs"))) + (is (eq source-placements (presentation-placements source))) + (is (eq target-placements (presentation-placements target))) + (is (equal "lime" (client-activity-id (find-client world "emacs")))) + (activate-view-strictly world "right" "browser") + (let ((revision (world-revision world))) + (signals invalid-transition (move-client-to-presentation world "emacs" (presentation-id target))) + (is (= revision (world-revision world)))) + (is (validate-world world)))) + +(test activity-deletion-cleans-checkpoints-cached-drafts-and-viewset-references + (let ((world (make-fixture))) + (create-activity world "old" "Old task") + (create-view world "old/view" "old" "Saved" nil) + (open-activity-draft world "left" "old") + (activate-view-strictly world "left" "old/view") + (activate-view-strictly world "left" "code") + (open-activity-draft world "right" "old") + (activate-view-strictly world "right" "browser") + (create-viewset world "mixed" "Mixed" (list (make-viewset-entry :head-id "left" :view-id "code") + (make-viewset-entry :head-id "right" :view-id "old/view"))) + (create-viewset world "only-old" "Only old" (list (make-viewset-entry :head-id "right" :view-id "old/view"))) + (let* ((revision (world-revision world)) + (summary (activity-deletion-summary world "old")) + (drafts (getf summary :presentation-ids)) + (left (current-presentation world "left")) + (right (current-presentation world "right"))) + (is-true (getf summary :ready-p)) + (is (= 2 (length drafts))) + (is (= 2 (getf summary :viewset-entry-count))) + (is (= revision (world-revision world))) + (delete-activity world "old" :expected-revision revision) + (signals unknown-entity (find-activity world "old")) + (signals unknown-entity (find-view world "old/view")) + (signals unknown-entity (find-viewset world "only-old")) + (dolist (id drafts) (signals unknown-entity (find-presentation world id))) + (is (equal '("code") (mapcar #'viewset-entry-view-id (viewset-entries (find-viewset world "mixed"))))) + (is (eq left (current-presentation world "left"))) + (is (eq right (current-presentation world "right"))) + (is (= 3 (hash-table-count (lime.core::world-leases world)))) + (is (= (1+ revision) (world-revision world))) + (is-true (validate-world world))))) + +(test activity-deletion-refuses-home-clients-even-hidden-or-shared-elsewhere + (let ((world (make-fixture))) + (create-activity world "music" "Music") + (create-client world "player" "music" :shared-p t) + (let ((revision (world-revision world))) + (signals invalid-transition (delete-activity world "music")) + (is (= revision (world-revision world)))) + (let ((p (open-activity-draft world "left" "lime"))) + (show-client-on-presentation world "player" (presentation-id p))) + (let ((revision (world-revision world))) + (signals invalid-transition (delete-activity world "music")) + (is (= revision (world-revision world))) + (is (equal "left" (lease-head-id world "player"))) + (is-true (validate-world world))))) + +(test activity-deletion-refuses-even-empty-mounts-on-any-head + (let ((world (make-fixture))) + (create-activity world "empty" "Empty") + (open-activity-draft world "left" "empty") + (open-activity-draft world "right" "empty") + (let ((revision (world-revision world))) + (is (= 2 (length (getf (activity-deletion-summary world "empty") :head-ids)))) + (signals invalid-transition (delete-activity world "empty")) + (is (= revision (world-revision world)))) + (activate-view-strictly world "left" "code") + (signals invalid-transition (delete-activity world "empty")) + (activate-view-strictly world "right" "browser") + (delete-activity world "empty") + (is-true (validate-world world)))) + +(test deleting-cached-shared-requests-never-retires-or-takes-the-client + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-activity world "borrower" "Borrower") + (create-view world "borrowed" "borrower" "Borrowed" (placements "terminal")) + (let ((p (open-activity-draft world "right" "borrower"))) + (show-client-on-presentation world "terminal" (presentation-id p))) + (activate-view-strictly world "right" "browser") + (activate-view-strictly world "left" "code") + (let ((lease (lease-for-client world "terminal"))) + (delete-activity world "borrower") + (is (eq lease (lease-for-client world "terminal"))) + (is (equal "lime" (client-activity-id (find-client world "terminal")))) + (is-true (client-shared-p (find-client world "terminal"))) + (is-true (validate-world world))))) + +(test stale-deletion-and-activation-plans-are-rejected + (let ((world (make-fixture))) + (create-activity world "old" "Old") + (let* ((summary (activity-deletion-summary world "old")) + (plan (build-strict-activation-plan (preflight-view-activation world "left" "code")))) + (create-client world "new" "old") + (let ((revision (world-revision world))) + (signals stale-transition-plan (delete-activity world "old" :expected-revision (getf summary :revision))) + (is (= revision (world-revision world)))) + (retire-client world "new") + (delete-activity world "old") + (signals stale-transition-plan (commit-activation-plan world plan)) + (is-true (validate-world world))))) + +(test shared-eligibility-does-not-duplicate-home-membership-or-grant-leases + (let* ((world (make-fixture)) (revision (world-revision world))) + (set-client-shared world "terminal" t) + (is (> (world-revision world) revision)) + (is (equal "lime" (client-activity-id (find-client world "terminal")))) + (is-false (member "terminal" (activity-client-ids (find-activity world "game")) :test #'equal)) + (is (member "terminal" (activity-available-client-ids world "game") :test #'equal)) + (is-false (lease-for-client world "terminal")) + (signals invalid-activity-membership + (create-view world "bad" "game" "Bad" (placements "emacs"))) + (create-view world "music" "game" "Music" (placements "terminal")) + (is-true (validate-world world)))) + +(test shared-cross-activity-views-use-the-existing-strict-partial-take-policies + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal" "game-client")) + (activate-view-strictly world "left" "code") + (let ((revision (world-revision world))) + (signals error (activate-view-strictly world "right" "music")) + (is (= revision (world-revision world)))) + (activate-view-partially world "right" "music") + (is (equal "left" (lease-head-id world "terminal"))) + (is (equal '("terminal") (presentation-unavailable-client-ids (current-presentation world "right")))) + (transfer-client-lease world "terminal" (presentation-id (current-presentation world "right"))) + (is (equal "right" (lease-head-id world "terminal"))) + (is (equal '("emacs") (presentation-client-ids (current-presentation world "left")))) + (is-true (validate-world world)) + (activate-view-taking world "left" "code") + (is (equal "left" (lease-head-id world "terminal"))) + (is-true (validate-world world)))) + +(test shared-window-can-switch-activities-on-the-same-head-without-collision + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal")) + (activate-view-strictly world "left" "code") + (activate-view-strictly world "left" "music") + (is (equal "left" (lease-head-id world "terminal"))) + (is-true (validate-world world)))) + +(test private-move-prunes-checkpoints-and-cached-drafts-without-switching-heads + (let ((world (make-fixture))) + (let ((cached (open-activity-draft world "left" "lime"))) + (show-client-on-presentation world "emacs" (presentation-id cached)) + (activate-view-strictly world "left" "code") + (activate-view-partially world "right" "docs") + (let* ((source (current-presentation world "left")) + (source-id (presentation-id source))) + (move-client-to-activity world "emacs" "game" :target-head-id "left") + (is (equal source-id (presentation-id (current-presentation world "left")))) + (is (equal "terminal" (presentation-focus-client-id source))) + (is (equal "game" (client-activity-id (find-client world "emacs")))) + (is-false (lease-for-client world "emacs")) + (is (eq cached source)) + (is (equal '("terminal") (presentation-client-ids cached))) + (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "code"))))) + (is (equal '("firefox") (mapcar #'placement-client-id (view-placements (find-view world "docs"))))) + (is-false (presentation-unavailable-client-ids (current-presentation world "right"))) + (let ((target (open-activity-draft world "left" "game"))) + (is (equal '("emacs") (presentation-client-ids target))) + (is (equal "left" (lease-head-id world "emacs")))) + (is-true (validate-world world)))))) + +(test move-retains-floating-geometry-and-destination-draft-settings + (let* ((world (make-fixture)) + (target (open-activity-draft world "left" "game" :default-layout :monocle))) + (show-client-on-presentation world "game-client" (presentation-id target)) + (activate-view-strictly world "left" "code") + (let ((source (current-presentation world "left"))) + (toggle-client-floating world (presentation-id source) "terminal" + :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2)) + (let ((data (copy-tree (placement-data (second (presentation-placements source)))))) + (move-client-to-activity world "terminal" "game" :target-head-id "left") + (is (eq target (activity-draft-for-head world "game" "left"))) + (is (eq :monocle (presentation-layout-mode target))) + (is (equal '("game-client" "terminal") (presentation-client-ids target))) + (is (eq :float (placement-kind (second (presentation-placements target))))) + (is (equal data (placement-data (second (presentation-placements target))))))) + (is-true (validate-world world)))) + +(test membership-policy-failure-leaves-no-partial-transition + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let* ((revision (world-revision world)) + (source (current-presentation world "left")) + (old-placements (presentation-placements source)) + (count (hash-table-count (lime.core::world-presentations world)))) + (signals error + (move-client-to-activity world "emacs" "game" :target-head-id "left" + :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy")))) + (is (= revision (world-revision world))) + (is (= count (hash-table-count (lime.core::world-presentations world)))) + (is (eq old-placements (presentation-placements source))) + (is (equal "lime" (client-activity-id (find-client world "emacs")))) + (is (equal "left" (lease-head-id world "emacs"))) + (signals error (move-client-to-activity world "emacs" "missing")) + (signals error (move-client-to-activity world "emacs" "game" :target-head-id "missing")) + (is (= revision (world-revision world))) + (is-true (validate-world world))))) + +(test revoke-sharing-prunes-foreign-requests-and-leases-but-keeps-home-checkpoints + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal" "game-client") :focus-client-id "terminal") + (let ((cached (open-activity-draft world "left" "game"))) + (show-client-on-presentation world "terminal" (presentation-id cached)) + (activate-view-strictly world "left" "music") + (set-client-shared world "terminal" nil) + (is-false (lease-for-client world "terminal")) + (is (equal '("game-client") (presentation-client-ids cached))) + (is (equal "game-client" (presentation-focus-client-id (current-presentation world "left")))) + (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "music"))))) + (is (equal '("emacs" "terminal") (mapcar #'placement-client-id (view-placements (find-view world "code"))))) + (is-false (member "terminal" (activity-available-client-ids world "game") :test #'equal)) + (is-true (validate-world world))))) + +(test moving-a-shared-client-changes-home-without-revoking-sharing + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (activate-view-strictly world "left" "code") + (move-client-to-activity world "terminal" "game" :target-head-id "left") + (is-true (client-shared-p (find-client world "terminal"))) + (is (equal "game" (client-activity-id (find-client world "terminal")))) + (is (member "terminal" (mapcar #'placement-client-id (view-placements (find-view world "code"))) :test #'equal)) + (is-false (lease-for-client world "terminal")) + (is (equal '("emacs") (presentation-client-ids (current-presentation world "left")))) + (is-true (validate-world world)) + (retire-client world "terminal") + (is-true (validate-world world)) + (is-false (presentation-client-ids (activity-draft-for-head world "game" "left"))))) + +(test moving-without-a-target-draft-parks-even-with-the-same-home + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (move-client-to-activity world "emacs" "lime") + (is-false (lease-for-client world "emacs")) + (is (equal '("terminal") (presentation-client-ids (current-presentation world "left")))) + (is-true (validate-world world)))) + +(test shared-viewset-still-rejects-two-simultaneous-claims + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal")) + (create-viewset world "duplicate" "Duplicate" + (list (make-viewset-entry :head-id "left" :view-id "code") + (make-viewset-entry :head-id "right" :view-id "music"))) + (let ((revision (world-revision world))) + (signals error (activate-viewset-taking world "duplicate")) + (is (= revision (world-revision world))) + (is-false (lease-for-client world "terminal"))))) + +(test sharing-and-moving-invalidate-previous-activation-plans + (dolist (operation (list (lambda (w) (set-client-shared w "terminal" t)) + (lambda (w) (move-client-to-activity w "terminal" "game")))) + (let* ((world (make-fixture)) + (plan (build-strict-activation-plan (preflight-view-activation world "left" "code")))) + (funcall operation world) + (signals stale-transition-plan (commit-activation-plan world plan)) + (is-true (validate-world world))))) + +(test private-here-preserves-the-current-arrangement-and-lease + (dolist (mode '(:manual :master-stack :monocle)) + (dolist (floating-p '(nil t)) + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal" "game-client") + :focus-client-id "terminal") + (let ((target (activate-view-strictly world "right" "music"))) + (set-presentation-layout-mode world (presentation-id target) mode) + (when floating-p + (toggle-client-floating world (presentation-id target) "terminal" + :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2))) + ;; A foreign active arrangement can still request the leased client. + (let* ((source (activate-view-partially world "left" "code")) + (revision (world-revision world)) + (lease (lease-for-client world "terminal")) + (other-lease (lease-for-client world "emacs")) + (before (lime.core::copy-presentation target)) + (checkpoint (view-placements (find-view world "music")))) + (is (equal '("terminal") (presentation-unavailable-client-ids source))) + (make-client-private-in-presentation world "terminal" (presentation-id target) + :expected-revision revision) + (is (= (1+ revision) (world-revision world))) + (is (equalp before target)) + (is (eq target (current-presentation world "right"))) + (is (eq lease (lease-for-client world "terminal"))) + (is (eq other-lease (lease-for-client world "emacs"))) + (is (equal "game" (client-activity-id (find-client world "terminal")))) + (is-false (client-shared-p (find-client world "terminal"))) + (is-false (member "terminal" (activity-client-ids (find-activity world "lime")) :test #'equal)) + (is (= 1 (count "terminal" (activity-client-ids (find-activity world "game")) :test #'equal))) + (is (eq checkpoint (view-placements (find-view world "music")))) + (is (equal '("emacs") (mapcar #'placement-client-id (view-placements (find-view world "code"))))) + (is (equal '("emacs") (presentation-client-ids source))) + (is-false (presentation-unavailable-client-ids source)) + (is (validate-world world)) + (make-client-private-in-presentation world "terminal" (presentation-id target)) + (is (= (1+ revision) (world-revision world))))))))) + +(test private-here-at-original-home-keeps-local-checkpoints-and-cleans-cached-guests + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal" "game-client") + :focus-client-id "terminal") + (let ((cached (activate-view-strictly world "right" "music"))) + (activate-view-strictly world "right" "browser") + (let* ((target (activate-view-strictly world "left" "code")) + (before (lime.core::copy-presentation target)) + (checkpoint (view-placements (find-view world "code")))) + (make-client-private-in-presentation world "terminal" (presentation-id target)) + (is (equalp before target)) + (is (eq checkpoint (view-placements (find-view world "code")))) + (is (equal "lime" (client-activity-id (find-client world "terminal")))) + (is (equal '("game-client") (presentation-client-ids cached))) + (is (equal "game-client" (presentation-focus-client-id cached))) + (is (equal '("game-client") (mapcar #'placement-client-id (view-placements (find-view world "music"))))) + (is (validate-world world)))))) + +(test private-here-validates-before-committing-anything + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal")) + (let* ((target (activate-view-strictly world "right" "music")) + (source (activate-view-partially world "left" "code")) + (revision (world-revision world)) + (lease (lease-for-client world "terminal")) + (checkpoint (view-placements (find-view world "code"))) + (old-source (lime.core::copy-presentation source)) + (old-target (lime.core::copy-presentation target))) + (signals stale-transition-plan + (make-client-private-in-presentation world "terminal" (presentation-id target) :expected-revision -1)) + (signals invalid-transition + (make-client-private-in-presentation world "terminal" (presentation-id source))) + (signals invalid-transition + (make-client-private-in-presentation world "firefox" (presentation-id source))) + (signals error + (make-client-private-in-presentation world "terminal" (presentation-id target) + :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy")))) + (is (= revision (world-revision world))) + (is (eq lease (lease-for-client world "terminal"))) + (is (eq checkpoint (view-placements (find-view world "code")))) + (is (equalp old-source source)) + (is (equalp old-target target)) + (is (client-shared-p (find-client world "terminal"))) + (is (equal "lime" (client-activity-id (find-client world "terminal")))) + (activate-view-strictly world "right" "browser") + (let ((revision (world-revision world))) + (signals invalid-transition + (make-client-private-in-presentation world "terminal" (presentation-id target))) + (is (= revision (world-revision world)))) + (is (validate-world world))))) + +(test revocation-is-atomic-if-a-focus-policy-fails + (let ((world (make-fixture))) + (set-client-shared world "terminal" t) + (create-view world "music" "game" "Music" (placements "terminal")) + (activate-view-strictly world "right" "music") + (let ((revision (world-revision world))) + (signals error + (set-client-shared world "terminal" nil + :focus-direction (lambda (c) (declare (ignore c)) (error "bad policy")))) + (is (= revision (world-revision world))) + (is-true (client-shared-p (find-client world "terminal"))) + (is (equal "right" (lease-head-id world "terminal"))) + (is-true (validate-world world))))) diff --git a/test/model.lisp b/test/model.lisp new file mode 100644 index 0000000..f4eafa4 --- /dev/null +++ b/test/model.lisp @@ -0,0 +1,955 @@ +(in-package #:lime.test) + +(def-suite lime-suite + :description "Lime's Activity/View/Head/Lease model.") + +(in-suite lime-suite) + +(defun placements (&rest client-ids) + (mapcar (lambda (client-id) + (make-placement :client-id client-id)) + client-ids)) + +(defun make-fixture () + (let ((world (make-world))) + (create-head world "left") + (create-head world "right") + (create-activity world "lime" "Lime development") + (create-activity world "game" "Game") + (create-client world "emacs" "lime" :name "Emacs") + (create-client world "terminal" "lime" :name "Terminal") + (create-client world "firefox" "lime" :name "Firefox") + (create-client world "game-client" "game" :name "Game") + (create-view world "code" "lime" "Code" + (placements "emacs" "terminal") + :focus-client-id "emacs") + (create-view world "docs" "lime" "Docs" + (placements "firefox" "emacs") + :focus-client-id "firefox") + (create-view world "browser" "lime" "Browser" + (placements "firefox") + :focus-client-id "firefox") + (create-view world "play" "game" "Play" + (placements "game-client")) + world)) + +(defun lease-head-id (world client-id) + (let ((lease (lease-for-client world client-id))) + (and lease + (presentation-head-id + (find-presentation world (lease-presentation-id lease)))))) + +(test views-respect-activity-ownership + (let ((world (make-fixture))) + (signals invalid-activity-membership + (create-view world "bad" "lime" "Bad" + (placements "game-client"))))) + +(test an-activity-needs-no-saved-view-to-own-live-head-local-drafts + (let ((world (make-world))) + (create-head world "left") + (create-head world "right") + (create-activity world "scratch" "Scratch") + (let ((left (open-activity-draft world "left" "scratch")) + (right (open-activity-draft world "right" "scratch"))) + (is-false (presentation-source-view-id left)) + (is-false (presentation-source-view-id right)) + (is (eq left (activity-draft-for-head world "scratch" "left"))) + (is (eq right (activity-draft-for-head world "scratch" "right"))) + ;; Reopening an Activity resumes its one draft on that Head rather than + ;; inventing a blank checkpoint or a second draft. + (is (eq left (open-activity-draft world "left" "scratch"))) + (is-false (activity-view-ids (find-activity world "scratch"))) + (is-true (validate-world world))))) + +(test a-default-layout-only-initializes-new-drafts + (dolist (mode '(:manual :master-stack :monocle)) + (let ((world (make-world))) + (create-head world "left") + (create-head world "right") + (create-activity world "work" "Work") + (let* ((revision (world-revision world)) + (report (preflight-activity-draft world "left" "work" :default-layout mode))) + (is (eq mode (activation-report-desired-layout-mode report))) + (is (= revision (world-revision world))) + (is-false (activity-draft-for-head world "work" "left"))) + (let ((draft (open-activity-draft world "left" "work" :default-layout mode))) + (is (eq mode (presentation-layout-mode draft))) + (when (eq mode :master-stack) + (is (equal '(:master-count 1 :master-ratio 3/5 :orientation :horizontal) + (presentation-layout-options draft)))) + (is-false (presentation-dirty-p draft)) + (set-presentation-monocle-layout world (presentation-id draft)) + (is (eq draft (open-activity-draft world "left" "work" :default-layout :master-stack))) + (is (eq :monocle (presentation-layout-mode draft))) + (is (eq :monocle + (activation-report-desired-layout-mode + (preflight-activity-draft world "left" "work" :default-layout :manual)))) + (is (eq mode (presentation-layout-mode + (open-activity-draft world "right" "work" :default-layout mode)))) + (is-true (validate-world world)) + (let ((revision (world-revision world))) + (signals invalid-transition + (open-activity-draft world "left" "work" :default-layout :bogus)) + (is (= revision (world-revision world)))))))) + +(test hiding-is-a-head-local-draft-edit-and-showing-restores-the-activity-client + (let ((world (make-fixture))) + (let ((presentation (activate-view-strictly world "left" "code"))) + ;; A saved View is a checkpoint, not the mutable list of every client + ;; owned by its Activity. Firefox begins parked for this Code draft. + (is (equal (presentation-hidden-client-ids world presentation) + '("firefox"))) + (hide-focused-client-in-presentation world (presentation-id presentation)) + ;; Hiding Emacs edits only this draft. It releases the real lease and + ;; moves focus to Terminal, while the Activity and original Code View + ;; remain intact for later recall. + (is (equal (presentation-client-ids presentation) '("terminal"))) + (is (equal (presentation-hidden-client-ids world presentation) + '("emacs" "firefox"))) + (is-false (lease-for-client world "emacs")) + (is (equal (presentation-focus-client-id presentation) "terminal")) + (is (equal (mapcar #'placement-client-id + (view-placements (find-view world "code"))) + '("emacs" "terminal"))) + (is-true (presentation-dirty-p presentation)) + ;; Revealing puts the client back in the live draft and acquires a + ;; lease. It never changes the older saved checkpoint implicitly. + (show-client-on-presentation world "emacs" (presentation-id presentation)) + (focus-client-on-presentation world "emacs" (presentation-id presentation)) + (is (equal (presentation-client-ids presentation) '("terminal" "emacs"))) + (is (equal (presentation-hidden-client-ids world presentation) + '("firefox"))) + (is (equal (lease-head-id world "emacs") "left")) + (is-true (validate-world world))))) + +(test view-names-are-unique-within-an-activity-but-not-globally + (let ((world (make-world))) + (create-activity world "work" "Work") + (create-activity world "chill" "Chill") + (create-view world "work/code" "work" "Code" '()) + (signals invalid-transition + (create-view world "work/code-2" "work" "code" '())) + (create-view world "chill/code" "chill" "Code" '()) + (is-true (validate-world world)))) + +(test distinct-views-of-one-activity-can-share-the-desktop + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((right (activate-view-strictly world "right" "browser"))) + (is (equal (presentation-source-view-id right) "browser")) + (is (equal (lease-head-id world "emacs") "left")) + (is (equal (lease-head-id world "firefox") "right")) + (is-true (validate-world world))))) + +(test strict-preflight-is-read-only-and-reports-a-client-collision + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((report (preflight-view-activation world "right" "docs"))) + (is-false (activation-report-ready-p report)) + (is (find :client-leased + (activation-report-conflicts report) + :key #'activation-conflict-kind)) + (signals activation-blocked + (build-strict-activation-plan report)) + (is (equal (lease-head-id world "emacs") "left")) + (is-false (current-presentation world "right"))))) + +(test partial-activation-preserves-the-incumbent-lease + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((right (activate-view-partially world "right" "docs"))) + (is (equal (presentation-leased-client-ids world right) + '("firefox"))) + (is (member "emacs" (presentation-unavailable-client-ids right) + :test #'equal)) + (is (equal (lease-head-id world "emacs") "left")) + (is (equal (lease-head-id world "firefox") "right")) + (is-true (validate-world world))))) + +(test taking-a-client-relocates-only-the-live-placement + (let ((world (make-fixture))) + (let ((left (activate-view-strictly world "left" "code"))) + (activate-view-taking world "right" "docs") + (is (equal (lease-head-id world "emacs") "right")) + (is-false (presentation-unavailable-client-ids left)) + (is (equal (presentation-client-ids left) '("terminal"))) + (is (equal (mapcar #'placement-client-id + (view-placements (find-view world "code"))) + '("emacs" "terminal"))) + (is-true (validate-world world))))) + +(test an-explicit-lease-transfer-is-a-general-command + (let ((world (make-fixture))) + (let ((left (activate-view-strictly world "left" "code")) + (right (activate-view-partially world "right" "docs"))) + (transfer-client-lease world "emacs" (presentation-id right)) + (is (equal (lease-head-id world "emacs") "right")) + (is-false (member "emacs" (presentation-client-ids left) :test #'equal)) + (is-false (member "emacs" (presentation-unavailable-client-ids right) + :test #'equal)) + (is-true (validate-world world))))) + +(test reclaiming-is-explicit-after-a-lease-becomes-free + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((right (activate-view-partially world "right" "docs"))) + ;; Switching the left Head away releases Emacs. It does not + ;; spontaneously appear on the right until the user asks to reclaim it. + (activate-view-strictly world "left" "play") + (is-false (lease-for-client world "emacs")) + (is (equal (reclaim-available-slots world (presentation-id right)) + '("emacs"))) + (is (equal (lease-head-id world "emacs") "right")) + (is-true (validate-world world))))) + +(test a-named-view-cannot-be-mounted-twice + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((report (preflight-view-activation world "right" "code"))) + (is (find :view-mounted + (activation-report-conflicts report) + :key #'activation-conflict-kind)) + (signals activation-blocked + (build-partial-activation-plan report))))) + +(test viewsets-swap-heads-as-one-atomic-activation + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (activate-view-strictly world "right" "play") + (create-viewset + world "after-work" "After work" + (list (make-viewset-entry :head-id "left" :view-id "play") + (make-viewset-entry :head-id "right" :view-id "code"))) + ;; Each incoming View is currently mounted on the other target Head. A + ;; pair of ordinary one-Head commands would reject that intermediate state; + ;; a Viewset recognizes both old Presentations as one outgoing group. + (let* ((report (preflight-viewset-activation world "after-work")) + (result (commit-viewset-plan world (build-strict-viewset-plan report)))) + (is-true (viewset-report-ready-p report)) + (is (equal (presentation-source-view-id + (current-presentation world "left")) + "play")) + (is (equal (presentation-source-view-id + (current-presentation world "right")) + "code")) + (is (equal (lease-head-id world "game-client") "left")) + (is (equal (lease-head-id world "emacs") "right")) + (is (equal (mapcar #'car (viewset-result-presentation-ids result)) + '("left" "right"))) + (is-true (validate-world world))))) + +(test viewsets-reuse-the-explicit-partial-and-take-lease-policies + (let ((world (make-fixture))) + (activate-view-strictly world "left" "browser") + (let ((right (activate-view-strictly world "right" "code"))) + (create-viewset + world "docs-left" "Docs on left" + (list (make-viewset-entry :head-id "left" :view-id "docs"))) + (let ((report (preflight-viewset-activation world "docs-left"))) + (is-false (viewset-report-ready-p report)) + (is (find :client-leased (viewset-report-conflicts report) + :key #'viewset-conflict-kind)) + (let ((result (commit-viewset-plan world + (build-partial-viewset-plan report)))) + (declare (ignore result)) + (is (equal (presentation-leased-client-ids + world (current-presentation world "left")) + '("firefox"))) + (is (member "emacs" + (presentation-unavailable-client-ids + (current-presentation world "left")) + :test #'equal)) + (is (equal (lease-head-id world "emacs") "right")))) + ;; Recalling the same Viewset with :TAKE is a second deliberate command: + ;; it moves only the contested Emacs lease and degrades the incumbent. + (commit-viewset-plan + world (build-taking-viewset-plan + (preflight-viewset-activation world "docs-left"))) + (is (equal (lease-head-id world "emacs") "left")) + (is-false (member "emacs" (presentation-client-ids right) :test #'equal)) + (is-true (validate-world world))))) + +(test viewset-plans-reject-internal-window-duplication-and-staleness + (let ((world (make-fixture))) + (create-viewset + world "bad-combination" "Bad combination" + (list (make-viewset-entry :head-id "left" :view-id "code") + ;; Code and Docs both request Emacs. A Viewset cannot pick one + ;; merely because its entry happened to come first. + (make-viewset-entry :head-id "right" :view-id "docs"))) + (let ((report (preflight-viewset-activation world "bad-combination"))) + (is (find :client-requested (viewset-report-conflicts report) + :key #'viewset-conflict-kind)) + (signals activation-blocked (build-partial-viewset-plan report)) + (is-false (current-presentation world "left")) + (is-false (current-presentation world "right"))) + (create-viewset world "valid" "Valid" + (list (make-viewset-entry :head-id "left" :view-id "browser"))) + (let ((plan (build-strict-viewset-plan + (preflight-viewset-activation world "valid")))) + ;; Any intervening model transition invalidates a prepared whole-desk + ;; plan; a stale command cannot replace a newly changed Head. + (create-client world "later" "lime") + (signals stale-transition-plan (commit-viewset-plan world plan)) + (is-false (current-presentation world "left")) + (is-true (validate-world world))))) + +(test new-windows-change-only-the-live-draft + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (create-client world "terminal-2" "lime" :name "Second terminal") + (show-client-on-presentation world "terminal-2" (presentation-id code)) + (is (member "terminal-2" (presentation-client-ids code) :test #'equal)) + (is-false (member "terminal-2" + (mapcar #'placement-client-id + (view-placements (find-view world "code"))) + :test #'equal)) + ;; Recalling the historical checkpoint releases the new client's lease. + (activate-view-strictly world "left" "code") + (is-false (lease-for-client world "terminal-2")) + (is-true (validate-world world))))) + +(test focus-is-an-explicit-active-lease-command + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (focus-client-on-presentation world "terminal" (presentation-id code)) + (is (equal (presentation-focus-client-id code) "terminal")) + (is-true (presentation-dirty-p code)) + ;; Firefox belongs to the Activity but is not visible in this + ;; Presentation, so selecting it must not create an implicit lease. + (signals invalid-transition + (focus-client-on-presentation world "firefox" (presentation-id code))) + (is (equal (presentation-focus-client-id code) "terminal")) + (is-true (validate-world world))))) + +(test retiring-a-destroyed-client-removes-phantom-slots-everywhere + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (retire-client world "emacs") + (signals unknown-entity (find-client world "emacs")) + (is-false (member "emacs" (activity-client-ids (find-activity world "lime")) + :test #'equal)) + (is (equal (presentation-client-ids code) '("terminal"))) + ;; This Presentation began with the fallback layout, so its tree remains + ;; implicit. Resolving it must still have no ghost slot. + (is (equal (mapcar #'car (resolve-presentation-layout code 800 600)) + '("terminal"))) + (is (equal (mapcar #'placement-client-id + (view-placements (find-view world "code"))) + '("terminal"))) + (is-false (lease-for-client world "emacs")) + (is (equal (lease-head-id world "terminal") "left")) + (is-true (validate-world world))))) + +(test head-local-layouts-are-copied-and-explicitly-saved + (let ((world (make-fixture))) + (let ((saved-layout + (make-layout-split + :orientation :vertical + :ratio 2/3 + :first (make-layout-leaf :client-id "emacs") + :second (make-layout-leaf :client-id "terminal")))) + (create-view world "layout" "lime" "Layout" + (placements "emacs" "terminal") + :layout-root saved-layout) + (let ((presentation (activate-view-strictly world "left" "layout"))) + (is (equal (layout-node-client-ids + (presentation-layout-root presentation)) + '("emacs" "terminal"))) + (is-false (eq saved-layout (presentation-layout-root presentation))) + (set-presentation-layout-root + world + (presentation-id presentation) + (make-layout-split + :orientation :horizontal + :ratio 1/2 + :first (make-layout-leaf :client-id "emacs") + :second (make-layout-leaf :client-id "terminal"))) + (is (eq (layout-split-orientation + (presentation-layout-root presentation)) + :horizontal)) + ;; The checkpoint remains vertical until the user explicitly updates it. + (is (eq (layout-split-orientation + (view-layout-root (find-view world "layout"))) + :vertical)) + (update-view-from-presentation world "layout" (presentation-id presentation)) + (is (eq (layout-split-orientation + (view-layout-root (find-view world "layout"))) + :horizontal)) + (is-true (validate-world world)))))) + +(test master-stack-is-a-head-local-saved-layout-policy + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (show-client-on-presentation world "firefox" (presentation-id code)) + (set-presentation-master-stack-layout + world (presentation-id code) :master-count 1 :master-ratio 3/5) + (is (eq (presentation-layout-mode code) :master-stack)) + (is (equal (presentation-layout-options code) + '(:master-count 1 :master-ratio 3/5 :orientation :horizontal))) + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("emacs" "terminal" "firefox"))) + (let ((layout (resolve-presentation-layout code 1000 600))) + (let ((master (cdr (assoc "emacs" layout :test #'equal))) + (first-stack (cdr (assoc "terminal" layout :test #'equal))) + (second-stack (cdr (assoc "firefox" layout :test #'equal)))) + (is (= (geometry-width master) 600)) + (is (= (geometry-width first-stack) 400)) + (is (= (geometry-y first-stack) 0)) + (is (= (geometry-y second-stack) 300)))) + ;; The policy follows the live draft as clients arrive and persists only + ;; when explicitly checkpointed. + (create-client world "terminal-2" "lime") + (show-client-on-presentation world "terminal-2" (presentation-id code)) + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("emacs" "terminal" "firefox" "terminal-2"))) + (update-view-from-presentation world "code" (presentation-id code)) + (is (eq (view-layout-mode (find-view world "code")) :master-stack)) + (is-true (validate-world world))))) + +(test master-stack-weights-resize-each-column-independently-on-both-axes + (let* ((world (make-fixture)) + (code (activate-view-strictly world "left" "code")) + (id (presentation-id code))) + (show-client-on-presentation world "firefox" id) + (dolist (client '("extra-1" "extra-2")) + (create-client world client "lime") + (show-client-on-presentation world client id)) + (set-presentation-master-stack-layout world id :master-count 2 :master-ratio 3/5) + (set-client-tile-weight world id "terminal" 2) + (set-client-tile-weight world id "firefox" 2) + (flet ((geometry (client layout) (cdr (assoc client layout :test #'equal)))) + (let ((layout (resolve-presentation-layout code 1000 600))) + ;; Master weights 1:2; stack weights 2:1:1. Neither changes column width. + (is (= 200 (geometry-height (geometry "emacs" layout)))) + (is (= 400 (geometry-height (geometry "terminal" layout)))) + (is (= 300 (geometry-height (geometry "firefox" layout)))) + (is (= 150 (geometry-height (geometry "extra-1" layout)))) + (is (= 150 (geometry-height (geometry "extra-2" layout)))) + (is (= 600 (geometry-width (geometry "terminal" layout)))) + (is (= 400 (geometry-width (geometry "firefox" layout))))) + (set-presentation-master-stack-layout world id :master-count 2 + :master-ratio 1/2 :orientation :vertical) + (let ((layout (resolve-presentation-layout code 600 1000))) + (is (= 200 (geometry-width (geometry "emacs" layout)))) + (is (= 400 (geometry-width (geometry "terminal" layout)))) + (is (= 300 (geometry-width (geometry "firefox" layout)))) + (is (= 150 (geometry-width (geometry "extra-1" layout)))) + (is (= 150 (geometry-width (geometry "extra-2" layout)))) + (is (= 500 (geometry-height (geometry "firefox" layout)))))) + (is (equal "emacs" (presentation-focus-client-id code))) + (is-true (validate-world world)))) + +(test tile-weights-follow-the-window-through-reordering-and-reflow + (let* ((world (make-fixture)) + (code (activate-view-strictly world "left" "code")) + (id (presentation-id code))) + (show-client-on-presentation world "firefox" id) + (set-presentation-master-stack-layout world id :master-ratio 3/5) + (set-client-tile-weight world id "terminal" 2) + (focus-client-on-presentation world "terminal" id) + (swap-focused-layout-client world id) + (is (eq :master-stack (presentation-layout-mode code))) + (is (equal '("emacs" "firefox" "terminal") (presentation-client-ids code))) + (let ((tile (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal)))) + (is (= 200 (geometry-y tile))) + (is (= 400 (geometry-height tile)))) + (create-client world "extra" "lime") + (show-client-on-presentation world "extra" id) + (is (= 300 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (retire-client world "extra") + (is (= 400 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (hide-client-from-presentation world "firefox" id) + ;; A sole window fills its column, with its weight retained for future peers. + (is (= 600 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (show-client-on-presentation world "firefox" id) + (is (= 400 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (is-true (validate-world world)))) + +(test tile-weights-survive-floating-resizing-and-layout-changes + (let* ((world (make-fixture)) + (code (activate-view-strictly world "left" "code")) + (id (presentation-id code))) + (show-client-on-presentation world "firefox" id) + (set-presentation-master-stack-layout world id) + (set-client-tile-weight world id "terminal" 2) + (toggle-client-floating world id "terminal") + (set-client-floating-geometry world id "terminal" :width 1/2) + (update-view-from-presentation world "code" id) + ;; Float checkpoint copies must preserve the dormant tiling weight too. + (setf code (activate-view-strictly world "left" "code") + id (presentation-id code)) + (toggle-client-floating world id "terminal") + (set-presentation-monocle-layout world id) + (set-presentation-manual-layout world id) + (set-presentation-master-stack-layout world id) + (is (= 400 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (is-true (validate-world world)))) + +(test tile-weights-are-independent-view-checkpoints-and-head-local-edits + (let* ((world (make-fixture)) + (code (activate-view-strictly world "left" "code")) + (id (presentation-id code)) + (right (activate-view-strictly world "right" "browser"))) + (set-presentation-master-stack-layout world id :master-count 2) + (set-client-tile-weight world id "terminal" 2) + (let ((saved (find "terminal" (view-placements (find-view world "code")) + :key #'placement-client-id :test #'equal))) + (is (= 1 (placement-tile-weight saved)))) + (update-view-from-presentation world "code" id) + (set-client-tile-weight world id "terminal" 1) + (is-true (presentation-dirty-p code)) + (is (= 300 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (setf code (activate-view-strictly world "left" "code")) + (is (= 400 (geometry-height + (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600) + :test #'equal))))) + (is-false (presentation-dirty-p code)) + (is (eq right (current-presentation world "right"))) + (is-false (presentation-dirty-p right)) + (is (equal "right" (lease-head-id world "firefox"))) + (is-true (validate-world world)))) + +(test invalid-tile-weight-edits-leave-the-draft-intact + (let* ((world (make-fixture)) + (code (activate-view-strictly world "left" "code")) + (id (presentation-id code))) + (set-presentation-master-stack-layout world id) + (let ((revision (world-revision world)) + (root (presentation-layout-root code))) + (dolist (weight '(0 -1 nope)) + (signals invalid-transition (set-client-tile-weight world id "terminal" weight))) + (signals invalid-transition (set-client-tile-weight world id "firefox" 2)) + (is (= revision (world-revision world))) + (is (eq root (presentation-layout-root code)))) + (toggle-client-floating world id "terminal") + (let ((revision (world-revision world))) + (signals invalid-transition (set-client-tile-weight world id "terminal" 2)) + (is (= revision (world-revision world)))) + (set-presentation-monocle-layout world id) + (let ((revision (world-revision world))) + (signals invalid-transition (set-client-tile-weight world id "emacs" 2)) + (is (= revision (world-revision world)))) + (signals invalid-transition + (create-view world "bad-weight" "lime" "Bad weight" + (list (make-placement :client-id "firefox" :data '(:tile-weight 0))))) + (signals invalid-transition + (master-stack-layout-root '("a" "b") :weights '(1))) + (signals invalid-transition + (master-stack-layout-root '("a" "b") :weights '(1 -1))) + (is-true (validate-world world)))) + +(test master-stack-client-flow-honors-insertion-and-focus-policy + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (set-presentation-master-stack-layout world (presentation-id code) + :master-count 1 :master-ratio 3/5) + ;; :BACK is the familiar dwm-like behavior: the newcomer is focused but + ;; every existing master/stack slot stays put and it joins at the + ;; visual bottom of the stack. + (show-client-on-presentation world "firefox" (presentation-id code) + :tiled-insertion-position :back :focus-p t) + (is (equal (presentation-client-ids code) + '("emacs" "terminal" "firefox"))) + (is (equal (presentation-focus-client-id code) "firefox")) + (let ((layout (resolve-presentation-layout code 1000 600))) + (is (= (geometry-y (cdr (assoc "firefox" layout :test #'equal))) 300))) + ;; Placement order points from master toward the bottom of the stack, + ;; so closing the focused lowest client with :PREVIOUS focuses Terminal. + (retire-client world "firefox" :focus-direction :previous) + (is (equal (presentation-focus-client-id code) "terminal")) + ;; The same engine also admits a different user policy without changing + ;; the master/stack implementation itself: :FRONT creates a new master. + (create-client world "browser-2" "lime") + (show-client-on-presentation world "browser-2" (presentation-id code) + :tiled-insertion-position :front :focus-p t) + (is (equal (presentation-client-ids code) + '("browser-2" "emacs" "terminal"))) + (is (equal (presentation-focus-client-id code) "browser-2")) + (retire-client world "browser-2" :focus-direction :previous) + ;; There is nothing before master, so the opposite direction is the + ;; graceful edge fallback. + (is (equal (presentation-focus-client-id code) "emacs")) + (is-true (validate-world world))))) + +(test monocle-client-flow-makes-new-clients-the-current-cycle-entry + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (set-presentation-monocle-layout world (presentation-id code)) + ;; In monocle placement order is the cycle below the visible client. A + ;; newcomer therefore goes first and becomes the one full-screen tile. + (show-client-on-presentation world "firefox" (presentation-id code) + :tiled-insertion-position :front :focus-p t) + (is (equal (presentation-client-ids code) + '("firefox" "emacs" "terminal"))) + (is (equal (presentation-focus-client-id code) "firefox")) + (is (equal (mapcar #'car (resolve-presentation-layout code 800 600)) + '("firefox"))) + ;; The next client in that order is the natural close target. Exercise + ;; RETIRE-CLIENT's per-container policy hook, used by the X11 adapter. + (retire-client world "firefox" + :focus-direction (lambda (container) + (declare (ignore container)) + :next)) + (is (equal (presentation-focus-client-id code) "emacs")) + (is (equal (mapcar #'car (resolve-presentation-layout code 800 600)) + '("emacs"))) + (is-true (validate-world world))))) + +(test monocle-renders-only-the-focused-tiled-client + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (set-presentation-monocle-layout world (presentation-id code)) + (is (eq (presentation-layout-mode code) :monocle)) + (let ((layout (resolve-presentation-layout code 800 600))) + (is (equal (mapcar #'car layout) '("emacs"))) + (is (= (geometry-width (cdar layout)) 800))) + (focus-client-on-presentation world "terminal" (presentation-id code)) + (is (equal (mapcar #'car (resolve-presentation-layout code 800 600)) + '("terminal"))) + (is-true (validate-world world))))) + +(test floating-placements-have-normalized-geometry-and-rejoin-tiling + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (toggle-focused-client-floating world (presentation-id code)) + (let ((placement (find "emacs" (presentation-placements code) + :key #'placement-client-id :test #'equal))) + (is (eq (placement-kind placement) :float)) + (is (equal (placement-data placement) + '(:x 1/8 :y 1/8 :width 3/4 :height 3/4)))) + ;; The float is independent of the tiled fallback tree and is resolved + ;; after tiled content so a renderer may keep it above the tiles. + (let ((layout (resolve-presentation-layout code 800 600))) + (is (equal (mapcar #'car layout) '("terminal" "emacs"))) + (let ((float (cdr (assoc "emacs" layout :test #'equal))) + (tile (cdr (assoc "terminal" layout :test #'equal)))) + (is (= (geometry-x float) 100)) + (is (= (geometry-y float) 75)) + (is (= (geometry-width float) 600)) + (is (= (geometry-height float) 450)) + (is (= (geometry-width tile) 800)))) + (set-client-floating-geometry world (presentation-id code) "emacs" + :x 1/4 :y 1/5 :width 1/2 :height 2/5) + (let ((float (cdr (assoc "emacs" + (resolve-presentation-layout code 800 600) + :test #'equal)))) + (is (= (geometry-x float) 200)) + (is (= (geometry-y float) 120)) + (is (= (geometry-width float) 400)) + (is (= (geometry-height float) 240))) + (toggle-client-floating world (presentation-id code) "emacs") + (let ((placement (find "emacs" (presentation-placements code) + :key #'placement-client-id :test #'equal))) + (is (eq (placement-kind placement) :tile)) + (is-false (placement-data placement))) + (is (equal (mapcar #'car (resolve-presentation-layout code 800 600)) + '("emacs" "terminal"))) + (is-true (validate-world world))))) + +(test floating-geometry-is-an-explicitly-saved-head-local-checkpoint-change + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (toggle-client-floating world (presentation-id code) "terminal" + :data '(:x 1/5 :y 1/6 :width 1/2 :height 1/2)) + ;; The named checkpoint remains tiled until the user asks to update it. + (is (eq (placement-kind + (find "terminal" (view-placements (find-view world "code")) + :key #'placement-client-id :test #'equal)) + :tile)) + (update-view-from-presentation world "code" (presentation-id code)) + (let ((saved (find "terminal" (view-placements (find-view world "code")) + :key #'placement-client-id :test #'equal))) + (is (eq (placement-kind saved) :float)) + (is (equal (placement-data saved) + '(:x 1/5 :y 1/6 :width 1/2 :height 1/2)))) + (set-client-floating-geometry world (presentation-id code) "terminal" + :x 1/4) + (is (equal (placement-data + (find "terminal" (view-placements (find-view world "code")) + :key #'placement-client-id :test #'equal)) + '(:x 1/5 :y 1/6 :width 1/2 :height 1/2))) + (is-true (validate-world world))))) + +(test master-stack-reflows-when-a-client-enters-or-leaves-floating + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (show-client-on-presentation world "firefox" (presentation-id code)) + (set-presentation-master-stack-layout world (presentation-id code) + :master-count 1 :master-ratio 3/5) + (toggle-client-floating world (presentation-id code) "terminal") + (is (eq (presentation-layout-mode code) :master-stack)) + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("emacs" "firefox"))) + (let ((layout (resolve-presentation-layout code 1000 600))) + (is (= (geometry-width (cdr (assoc "emacs" layout :test #'equal))) 600)) + (is (= (geometry-width (cdr (assoc "firefox" layout :test #'equal))) 400)) + (is (= (geometry-width (cdr (assoc "terminal" layout :test #'equal))) + 750))) + (toggle-client-floating world (presentation-id code) "terminal") + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("emacs" "terminal" "firefox"))) + (is-true (validate-world world))))) + +(test manual-layout-commands-edit-the-focused-nearest-split + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (adjust-focused-layout-split-ratio world (presentation-id code) 1/10) + (is (eq (presentation-layout-mode code) :manual)) + (is (= (layout-split-ratio (presentation-layout-root code)) 3/5)) + (set-focused-layout-split-orientation world (presentation-id code) + :vertical) + (is (eq (layout-split-orientation (presentation-layout-root code)) + :vertical)) + (swap-focused-layout-client world (presentation-id code)) + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("terminal" "emacs"))) + (is-true (validate-world world))))) + +(test promoting-a-client-creates-a-master-stack-draft + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (show-client-on-presentation world "firefox" (presentation-id code)) + (focus-client-on-presentation world "terminal" (presentation-id code)) + (promote-client-to-master world (presentation-id code) "terminal") + (is (eq (presentation-layout-mode code) :master-stack)) + (is (equal (layout-node-client-ids (presentation-layout-root code)) + '("terminal" "emacs" "firefox"))) + (is (equal (mapcar #'placement-client-id + (presentation-placements code)) + '("terminal" "emacs" "firefox"))) + (is-true (validate-world world))))) + +(test resuming-a-cached-presentation-preserves-its-draft + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (create-client world "terminal-2" "lime") + (show-client-on-presentation world "terminal-2" (presentation-id code)) + (activate-view-strictly world "left" "play") + (let ((resumed (resume-presentation-strictly world "left" + (presentation-id code)))) + (is (eq code resumed)) + (is (member "terminal-2" (presentation-client-ids resumed) + :test #'equal)) + (is (equal (lease-head-id world "terminal-2") "left")) + (is-true (presentation-dirty-p resumed)) + (is-true (validate-world world)))))) + +(test resume-keeps-current-locations-instead-of-recalling-checkpoint-requests + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (activate-view-strictly world "left" "play") + (activate-view-strictly world "right" "docs") + (let ((report (preflight-presentation-resume world "left" + (presentation-id code)))) + (is (activation-report-ready-p report)) + (is (equal '("terminal") (mapcar #'placement-client-id (activation-report-desired-placements report))))) + (let ((resumed (resume-presentation-strictly world "left" + (presentation-id code)))) + (is (eq code resumed)) + (is-false (presentation-unavailable-client-ids resumed)) + (is (equal (lease-head-id world "terminal") "left")) + (is (equal (lease-head-id world "emacs") "right")) + (is-true (validate-world world)))))) + +(test updating-a-view-is-explicit + (let ((world (make-fixture))) + (let ((code (activate-view-strictly world "left" "code"))) + (create-client world "terminal-2" "lime") + (show-client-on-presentation world "terminal-2" (presentation-id code)) + (update-view-from-presentation world "code" (presentation-id code)) + (is (member "terminal-2" + (mapcar #'placement-client-id + (view-placements (find-view world "code"))) + :test #'equal)) + (is-false (presentation-dirty-p code))))) + +(test a-degraded-presentation-cannot-silently-overwrite-a-view + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let ((right (activate-view-partially world "right" "docs"))) + (signals degraded-presentation-update + (update-view-from-presentation world "docs" (presentation-id right)))))) + +(test topology-reconciliation-moves-a-removed-heads-live-draft-intact + (let ((world (make-fixture))) + (let* ((code (activate-view-strictly world "left" "code")) + (browser (activate-view-strictly world "right" "browser")) + (report (preflight-head-topology-reconciliation world + '("left" "dock")))) + (is (equal (head-topology-report-added-head-ids report) '("dock"))) + (is (equal (head-topology-report-removed-head-ids report) '("right"))) + (is (equal (mapcar #'head-topology-source-presentation-id + (head-topology-report-removed-active-sources report)) + (list (presentation-id browser)))) + (let ((result + (commit-head-topology-reconciliation-plan + world + (build-head-topology-reconciliation-plan + report + :moves (list (make-head-topology-move + :from-head-id "right" :to-head-id "dock")))))) + (is (equal (head-topology-result-moved-presentation-ids result) + (list (presentation-id browser)))) + (is (eq (current-presentation world "left") code)) + (is (eq (current-presentation world "dock") browser)) + (is (equal (presentation-head-id browser) "dock")) + (is (equal (lease-head-id world "firefox") "dock")) + (signals unknown-entity (find-head world "right")) + (is-true (validate-world world)))))) + +(test topology-reconciliation-suspends-an-unmoved-draft-and-allows-rehoming + (let ((world (make-fixture))) + (activate-view-strictly world "left" "code") + (let* ((browser (activate-view-strictly world "right" "browser")) + (remove-report (preflight-head-topology-reconciliation world '("left"))) + (result + (commit-head-topology-reconciliation-plan + world (build-head-topology-reconciliation-plan remove-report)))) + (is (equal (head-topology-result-suspended-presentation-ids result) + (list (presentation-id browser)))) + (is-false (presentation-head-id browser)) + (is-false (lease-for-client world "firefox")) + (let ((add-report + (preflight-head-topology-reconciliation world '("left" "laptop")))) + (commit-head-topology-reconciliation-plan + world (build-head-topology-reconciliation-plan add-report))) + (let ((resumed (resume-presentation-strictly world "laptop" + (presentation-id browser)))) + (is (eq resumed browser)) + (is (equal (presentation-head-id browser) "laptop")) + (is (equal (lease-head-id world "firefox") "laptop")) + (is-true (validate-world world)))))) + +(test topology-reconciliation-rejects-ambiguous-destinations-without-mutation + (let ((world (make-fixture))) + (create-head world "third") + (activate-view-strictly world "left" "code") + (activate-view-strictly world "right" "browser") + (activate-view-strictly world "third" "play") + (let ((report (preflight-head-topology-reconciliation world '("left")))) + (signals invalid-transition + (build-head-topology-reconciliation-plan + report + :moves (list (make-head-topology-move :from-head-id "right" + :to-head-id "left") + (make-head-topology-move :from-head-id "third" + :to-head-id "left")))) + (is (current-presentation world "right")) + (is (current-presentation world "third")) + (is-true (validate-world world))))) + +(test stale-plans-cannot-overwrite-newer-state + (let ((world (make-fixture))) + (let* ((report (preflight-view-activation world "left" "code")) + (plan (build-strict-activation-plan report))) + (create-client world "terminal-2" "lime") + (signals stale-transition-plan + (commit-activation-plan world plan)) + (is-false (current-presentation world "left"))))) + +(test activity-is-one-live-arrangement-across-independently-selected-heads + (let* ((world (make-fixture)) + (left (open-activity-draft world "left" "lime" :default-layout :master-stack)) + (right (open-activity-draft world "right" "lime" :default-layout :monocle))) + (show-client-on-presentation world "emacs" (presentation-id left)) + (show-client-on-presentation world "firefox" (presentation-id right)) + (set-presentation-layout-mode world (presentation-id left) :master-stack :layout-options '(:master-ratio 2/3)) + (dotimes (i 3) + (open-activity-draft world "right" "game") + (is (equal "left" (lease-head-id world "emacs"))) + (is-false (lease-for-client world "firefox")) + (open-activity-draft world "left" "game") + (is-false (lease-for-client world "emacs")) + ;; Return in either order, independently. No save/recall or policy choice. + (dolist (head (if (evenp i) '("right" "left") '("left" "right"))) + (is (activation-report-ready-p (preflight-activity-draft world head "lime"))) + (open-activity-draft world head "lime")) + (is (eq left (current-presentation world "left"))) + (is (eq right (current-presentation world "right"))) + (is (equal "left" (lease-head-id world "emacs"))) + (is (equal "right" (lease-head-id world "firefox")))) + (is (= 2/3 (getf (presentation-layout-options left) :master-ratio))) + (is (eq :monocle (presentation-layout-mode right))) + ;; Explicit relocation changes the source even after another round trip. + (show-client-on-presentation world "firefox" (presentation-id left)) + (transfer-client-lease world "firefox" (presentation-id left)) + (is-false (presentation-client-ids right)) + (open-activity-draft world "right" "game") + (open-activity-draft world "right" "lime") + (is-false (presentation-client-ids right)) + (is (equal "left" (lease-head-id world "firefox"))) + ;; Hiding does not resurface through another arrangement or a return. + (hide-client-from-presentation world "firefox" (presentation-id left)) + (open-activity-draft world "left" "game") + (open-activity-draft world "left" "lime") + (is-false (lease-for-client world "firefox")) + (is (equal '("emacs") (presentation-client-ids left))) + (is-true (validate-world world)))) + +(test first-visit-to-inactive-activity-does-not-gather-other-heads-windows + (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime"))) + (show-client-on-presentation world "emacs" (presentation-id left)) + (open-activity-draft world "left" "game") + (is-false (presentation-client-ids (open-activity-draft world "right" "lime"))) + (is-false (lease-for-client world "emacs")) + ;; Summoning a not-currently-visible client also updates its old location. + (show-client-on-presentation world "emacs" (presentation-id (current-presentation world "right"))) + (is-false (presentation-client-ids left)) + (open-activity-draft world "left" "lime") + (is (equal "right" (lease-head-id world "emacs"))) + (is-true (validate-world world)))) + +(test checkpoints-edit-one-working-arrangement-without-creating-hidden-workspaces + (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime"))) + (activate-view-strictly world "left" "code") + (is (eq left (current-presentation world "left"))) + (hide-client-from-presentation world "emacs" (presentation-id left)) + (open-activity-draft world "left" "game") + (is (eq left (open-activity-draft world "left" "lime"))) + (is (equal '("terminal") (presentation-client-ids left))) + (activate-view-strictly world "left" "code") + (is (equal '("emacs" "terminal") (presentation-client-ids left))) + (is-false (presentation-dirty-p left)) + ;; Recalling the checkpoint elsewhere while the old side is inactive + ;; changes live locations and detaches its old source label, not the View. + (open-activity-draft world "left" "game") + (activate-view-strictly world "right" "code") + (is-false (presentation-source-view-id left)) + (is-false (presentation-client-ids left)) + (open-activity-draft world "left" "lime") + (is (equal "right" (lease-head-id world "emacs"))) + (is (= 2 (length (view-placements (find-view world "code"))))) + (is-true (validate-world world)))) + +(test partially-recalled-view-does-not-retry-missing-windows-on-activity-return + (let* ((world (make-fixture)) + (left (activate-view-strictly world "left" "code")) + (right (activate-view-partially world "right" "docs"))) + (is (equal '("emacs") (presentation-unavailable-client-ids right))) + (open-activity-draft world "right" "game") + (open-activity-draft world "left" "game") + (open-activity-draft world "right" "lime") + (is-false (lease-for-client world "emacs")) + (is (equal '("firefox") (presentation-client-ids right))) + (open-activity-draft world "left" "lime") + (is (eq left (current-presentation world "left"))) + (is (equal "left" (lease-head-id world "emacs"))) + (is-true (validate-world world)))) + +(defun run-tests () + (run! 'lime-suite)) diff --git a/test/package.lisp b/test/package.lisp new file mode 100644 index 0000000..6ebbe0d --- /dev/null +++ b/test/package.lisp @@ -0,0 +1,3 @@ +(defpackage #:lime.test + (:use #:cl #:fiveam #:lime.core) + (:export #:run-tests)) diff --git a/test/persistence.lisp b/test/persistence.lisp new file mode 100644 index 0000000..595223f --- /dev/null +++ b/test/persistence.lisp @@ -0,0 +1,215 @@ +(defpackage #:lime.persistence.test + (:use #:cl #:fiveam #:lime.core #:lime.persistence) + (:export #:run-tests)) +(in-package #:lime.persistence.test) +(def-suite persistence-suite) +(in-suite persistence-suite) + +(defun fixture () + (let ((world (make-world))) + (dolist (head '("left" "right")) (create-head world head)) + (create-activity world "work" "Lime 日本語") + (create-activity world "game" "Game") + (dolist (id '("editor" "terminal" "browser" "hidden")) + (create-client world id "work" :name id :metadata '(:note "plain data"))) + (create-view world "code" "work" "Code" + (mapcar (lambda (id) (make-placement :client-id id)) '("editor" "terminal")) + :layout-mode :master-stack :layout-options '(:master-ratio 2/3) + :focus-client-id "terminal") + (create-view world "docs" "work" "Docs" + (mapcar (lambda (id) (make-placement :client-id id)) '("browser" "editor")) + :layout-mode :monocle :focus-client-id "browser") + (activate-view-strictly world "left" "code") + (activate-view-partially world "right" "docs") + (let ((p (current-presentation world "left"))) + (set-client-tile-weight world (presentation-id p) "editor" 3/2) + (toggle-client-floating world (presentation-id p) "terminal" + :data '(:x 1/4 :y 1/3 :width 1/2 :height 1/2))) + ;; Make a cached draft as well as the active checkpoint realizations. + (open-activity-draft world "left" "game") + (activate-view-strictly world "left" "code") + (create-viewset world "desk" "Desk" (list (make-viewset-entry :head-id "left" :view-id "code") + (make-viewset-entry :head-id "right" :view-id "docs"))) + world)) + +(test deleted-activity-and-associated-library-stay-deleted-after-restore + (let ((world (fixture))) + (create-view world "game/empty" "game" "Empty" nil) + (create-viewset world "obsolete" "Obsolete" (list (make-viewset-entry :head-id "left" :view-id "game/empty"))) + (delete-activity world "game") + (let ((restored (restore-world (snapshot-world world)))) + (is (equalp (snapshot-world world) (snapshot-world restored))) + (signals unknown-entity (find-activity restored "game")) + (signals unknown-entity (find-view restored "game/empty")) + (signals unknown-entity (find-viewset restored "obsolete")) + (is-true (validate-world restored))))) + +(test sharing-and-moved-drafts-survive-roundtrip + (let ((world (fixture))) + (set-client-shared world "terminal" t) + (open-activity-draft world "left" "game") + (show-client-on-presentation world "terminal" (presentation-id (current-presentation world "left"))) + (move-client-to-activity world "browser" "game" :target-head-id "right") + (let ((restored (restore-world (snapshot-world world)))) + (is (equalp (snapshot-world world) (snapshot-world restored))) + (is-true (client-shared-p (find-client restored "terminal"))) + (is (equal "work" (client-activity-id (find-client restored "terminal")))) + (is (equal "game" (presentation-activity-id + (find-presentation restored (lease-presentation-id (lease-for-client restored "terminal")))))) + (is (equal '("browser") (presentation-client-ids (activity-draft-for-head restored "game" "right"))))) + (let ((data (snapshot-world world))) + (setf (getf (first (getf data :clients)) :shared) :invalid) + (signals error (restore-world data))))) + +(test version-one-snapshots-upgrade-to-private-clients + (let* ((world (fixture)) (data (snapshot-world world))) + (setf (getf data :version) 1) + (dolist (row (getf data :clients)) (remf row :shared)) + (let ((restored (restore-world data))) + (is (equalp (snapshot-world world) (snapshot-world restored))) + (is-false (client-shared-p (find-client restored "terminal")))))) + +(test lossless-model-roundtrip-and-independent-objects + (let* ((world (fixture)) (data (snapshot-world world)) (restored (restore-world data))) + (is (equalp data (snapshot-world restored))) + (is-true (validate-world restored)) + (is (equal '("hidden") + (set-difference (activity-client-ids (find-activity restored "work")) + '("editor" "terminal" "browser") :test #'equal))) + (is-false (presentation-unavailable-client-ids (current-presentation restored "right"))) + (is (= 3 (hash-table-count (lime.core::world-leases restored)))) + (setf (client-metadata (find-client restored "editor")) '(:changed t)) + (is (equal '(:note "plain data") (client-metadata (find-client world "editor")))) + (let ((old (hash-table-count (lime.core::world-presentations restored)))) + (open-activity-draft restored "right" "game") + (is (= (1+ old) (hash-table-count (lime.core::world-presentations restored))))))) + +(test checkpoints-and-dirty-drafts-are-distinct + (let* ((world (fixture)) (p (current-presentation world "left"))) + (hide-client-from-presentation world "terminal" (presentation-id p)) + (let* ((restored (restore-world (snapshot-world world))) (p2 (current-presentation restored "left"))) + (is-true (presentation-dirty-p p2)) + (is (equal '("editor") (presentation-client-ids p2))) + (is (= 2 (length (view-placements (find-view restored "code"))))) + (is (member "terminal" (presentation-hidden-client-ids restored p2) :test #'equal))))) + +(test manual-tree-and-empty-library-roundtrip + (let* ((world (fixture)) (p (current-presentation world "left"))) + (set-presentation-manual-layout world (presentation-id p)) + (set-presentation-layout-root world (presentation-id p) + (make-layout-split :orientation :vertical :ratio 2/5 + :first (make-layout-leaf :client-id "editor") + :second (make-layout-leaf :client-id "terminal"))) + (is (equalp (snapshot-world world) (snapshot-world (restore-world (snapshot-world world)))))) + (let ((world (make-world))) + (create-head world "one") (create-activity world "plain" "Plain") + (open-activity-draft world "one" "plain") + (let ((restored (restore-world (snapshot-world world)))) + (is-false (activity-view-ids (find-activity restored "plain"))) + (is-false (presentation-source-view-id (current-presentation restored "one"))) + (is-true (validate-world restored))))) + +(test displays-have-independent-default-stores + (is (not (equal (default-session-path ":0") (default-session-path ":99")))) + (is (not (equal (default-session-path ":0") (default-session-path "_3A0"))))) + +(test malformed-snapshots-are-rejected-before-a-world-is-returned + (let ((data (snapshot-world (fixture)))) + (flet ((reject (function) + (let ((copy (copy-tree data))) (funcall function copy) (signals error (restore-world copy))))) + (reject (lambda (x) (setf (getf x :version) 99))) + (reject (lambda (x) (setf (getf (first (getf x :activities)) :clients) '("bogus")))) + (reject (lambda (x) (setf (getf (first (getf x :clients)) :activity) "missing"))) + (reject (lambda (x) (setf (getf (first (getf x :heads)) :active) "missing"))) + (reject (lambda (x) (setf (getf (first (getf x :presentations)) :layout) :bogus))) + (reject (lambda (x) (setf (getf (first (getf x :presentations)) :dirty) 12))) + (reject (lambda (x) + ;; Give a second live arrangement an actual duplicate client. + (let ((right (find "right" (getf x :presentations) :key (lambda (p) (getf p :head)) :test #'equal))) + (push '(:client "editor" :kind :float :data (:x 0 :y 0 :width 1 :height 1)) + (getf right :placements))))) + (reject (lambda (x) (push (first (getf x :views)) (getf x :views))))))) + +(test plain-data-only + (is-true (check-data (make-list 10000 :initial-element :wide))) + (signals error (check-data (list :callback #'identity))) + (signals error (check-data (make-world))) + (let ((cycle (list :cycle))) + (setf (cdr cycle) cycle) + (signals error (check-data cycle))) + (signals error (check-data (loop repeat 140 for x = '(:end) then (list x) finally (return x))))) + +(test legacy-arrangements-consolidate-without-touching-windows-or-checkpoints + (let* ((world (fixture)) (ignored (create-head world "third")) + (data (snapshot-world world)) + (active (find "left" (getf data :heads) :key (lambda (h) (getf h :id)) :test #'equal)) + (row (find (getf active :active) (getf data :presentations) :key (lambda (p) (getf p :id)) :test #'equal)) + (duplicate (copy-tree row)) (stale (copy-tree row))) + (declare (ignore ignored)) + (setf (getf duplicate :id) "presentation-900" + (getf stale :id) "presentation-901" (getf stale :head) "third") + (push duplicate (getf data :presentations)) + (push stale (getf data :presentations)) + ;; Version 3 rejects duplicates instead of silently repairing corruption. + (signals error (restore-world data)) + (setf (getf data :version) 2) + (let* ((restored (restore-world data)) (after (snapshot-world restored))) + (dolist (key '(:clients :activities :views :viewsets :heads)) + (is (equalp (getf data key) (getf after key)))) + (is (equalp row (find (getf row :id) (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal))) + (signals unknown-entity (find-presentation restored "presentation-900")) + (is-false (presentation-client-ids (find-presentation restored "presentation-901"))) + (is-false (presentation-source-view-id (find-presentation restored "presentation-901"))) + (normalize-activity-arrangements restored) + (is (equalp after (snapshot-world restored))) + (is-true (validate-world restored))))) + +(test worker-copy-does-not-share-mutable-strings + (let* ((text (copy-seq "Original")) (data (list :name text :pair (cons :label text))) + (copy (copy-data data))) + (setf (char text 0) #\X) + (is (string= "Original" (getf copy :name))) + (is (string= "Original" (cdr (getf copy :pair)))))) + +(defmacro with-store ((store path) &body body) + `(uiop:with-temporary-file (:pathname ,path :prefix "lime-persistence-test-") + (delete-file ,path) + (let ((,store (open-session-store ,path))) + (unwind-protect (progn ,@body) + (close-session-store ,store) + (let ((lock (pathname (concatenate 'string (namestring ,path) ".lock")))) + (when (probe-file lock) (delete-file lock))))))) + +(test atomic-private-storage-and-writer-exclusion + (with-store (store path) + (is-false (read-session-store store)) + (signals error (open-session-store path)) + (is (= 1 (logand 1 (cffi:foreign-funcall "fcntl" :int (lime.persistence::session-store-descriptor store) :int 1 :int)))) + (let ((data (snapshot-world (fixture)))) + (write-session-store store data) + (is (equalp data (read-session-store store))) + (is (string= "600" (string-trim '(#\Newline) (uiop:run-program (list "stat" "-c" "%a" (namestring path)) :output :string)))) + (let ((original (symbol-function 'lime.persistence::%sync-path))) + (unwind-protect + (progn + (setf (symbol-function 'lime.persistence::%sync-path) + (lambda (path) (declare (ignore path)) (error "Injected disk failure"))) + (signals error (write-session-store store '(:replacement t)))) + (setf (symbol-function 'lime.persistence::%sync-path) original))) + (is (equalp data (read-session-store store)))) + (close-session-store store) + (let ((again (open-session-store path))) + (is-true again) (close-session-store again)))) + +(defvar *read-executed* nil) +(test reader-does-not-evaluate-or-accept-trailing-truncated-or-circular-data + (with-store (store path) + (dolist (text '("#.(setf lime.persistence.test::*read-executed* t)" + "#S(LIME.CORE::WORLD)" "#1=(:cycle . #1#)" "(:one 1) (:two 2)" + "(:missing" "" "(:text \"unterminated)")) + (with-open-file (stream path :direction :output :if-exists :supersede) + (write-string text stream)) + (signals error (read-session-store store))) + (is-false *read-executed*))) + +(defun run-tests () (unless (run! 'persistence-suite) (error "Persistence tests failed."))) diff --git a/test/presentation-navigation.lisp b/test/presentation-navigation.lisp new file mode 100644 index 0000000..1dcc7a4 --- /dev/null +++ b/test/presentation-navigation.lisp @@ -0,0 +1,85 @@ +(in-package #:lime.test) +(in-suite lime-suite) + +(defun make-presentation-navigation-fixture () + (let ((w (make-world))) + (dolist (id '("left" "right" "third")) (create-head w id)) + (dolist (id '("work" "chat" "other")) (create-activity w id id)) + (dolist (row '(("browser" "work") ("terminal" "work") ("discord" "chat") + ("hidden" "chat") ("shared" "chat"))) + (create-client w (first row) (second row))) + (set-client-shared w "shared" t) + (create-view w "work/code" "work" "Code" (placements "browser")) + (create-view w "chat/chat" "chat" "Chat" (placements "discord" "shared")) + (activate-view-strictly w "left" "work/code") + (activate-view-strictly w "right" "chat/chat") + w)) + +(test portable-arrangement-swaps-preserve-state-and-lease-identity + (let* ((w (make-presentation-navigation-fixture)) + (work (current-presentation w "left")) (chat (current-presentation w "right")) + (leases (mapcar (lambda (id) (lease-for-client w id)) '("browser" "discord" "shared"))) + (view-before (lime.core::%copy-placements (view-placements (find-view w "chat/chat"))))) + (set-presentation-layout-mode w (presentation-id chat) :monocle) + (let ((report (preflight-presentation-bring w "left" (presentation-id chat))) + (before (world-revision w))) + (is (activation-report-ready-p report)) + (is (= before (world-revision w)))) + (bring-presentation-to-head w (presentation-id chat) "left") + (is (eq chat (current-presentation w "left"))) + (is (eq work (current-presentation w "right"))) + (is (equal "left" (presentation-head-id chat))) + (is (equal "right" (presentation-head-id work))) + (is (eq :monocle (presentation-layout-mode chat))) + (is (presentation-dirty-p chat)) + (is (equalp view-before (view-placements (find-view w "chat/chat")))) + (is (null (lease-for-client w "hidden"))) + (loop for id in '("browser" "discord" "shared") for old in leases + do (is (eq old (lease-for-client w id)))) + (dotimes (i 20) + (bring-presentation-to-head w (presentation-id chat) (if (evenp i) "right" "left")) + (is (validate-world w))) + (let ((revision (world-revision w))) + (bring-presentation-to-head w (presentation-id chat) "left") + (is (= revision (world-revision w)))))) + +(test swaps-transpose-cached-extended-portions-without-erasing-them + (let* ((w (make-presentation-navigation-fixture)) (chat (current-presentation w "right")) + (work-left (current-presentation w "left"))) + (create-view w "work/logs" "work" "Logs" (placements "terminal")) + (let ((work-right (activate-view-strictly w "right" "work/logs"))) + (resume-presentation-strictly w "right" (presentation-id chat)) + (bring-presentation-to-head w (presentation-id chat) "left") + (is (eq work-left (current-presentation w "right"))) + (is (eq work-right (activity-draft-for-head w "work" "left"))) + (is (equal '("terminal") (presentation-client-ids work-right))) + (is (equal "work/logs" (presentation-source-view-id work-right))) + (is (null (lease-for-client w "terminal"))) + (is (validate-world w)) + (open-activity-draft w "left" "work") + (is (eq work-right (current-presentation w "left"))) + (is (validate-world w))))) + +(test inactive-portable-return-does-not-change-other-displays-or-recall-missing-slots + (let* ((w (make-presentation-navigation-fixture)) (chat (current-presentation w "right"))) + (open-activity-draft w "right" "other") + (let ((other (current-presentation w "right"))) + (bring-presentation-to-head w (presentation-id chat) "left") + (is (eq other (current-presentation w "right"))) + (is (eq chat (current-presentation w "left"))) + (is (null (lease-for-client w "browser"))) + (is (null (lease-for-client w "hidden"))) + (is (validate-world w))) + (let ((before (world-revision w))) + (signals stale-transition-plan + (bring-presentation-to-head w (presentation-id chat) "third" :expected-revision (1- before))) + (signals unknown-entity (bring-presentation-to-head w (presentation-id chat) "missing")) + (is (= before (world-revision w)))) + ;; A topology-suspended arrangement is still portable. + (commit-head-topology-reconciliation-plan w + (build-head-topology-reconciliation-plan + (preflight-head-topology-reconciliation w '("right" "third")))) + (is (null (presentation-head-id chat))) + (bring-presentation-to-head w (presentation-id chat) "third") + (is (eq chat (current-presentation w "third"))) + (is (validate-world w)))) diff --git a/test/ui-package.lisp b/test/ui-package.lisp new file mode 100644 index 0000000..a5477c2 --- /dev/null +++ b/test/ui-package.lisp @@ -0,0 +1,2 @@ +(defpackage #:lime.ui.test + (:use #:cl #:fiveam #:lime.ui)) diff --git a/test/ui.lisp b/test/ui.lisp new file mode 100644 index 0000000..1e96c93 --- /dev/null +++ b/test/ui.lisp @@ -0,0 +1,209 @@ +(in-package #:lime.ui.test) + +(def-suite lime-ui-suite + :description "Renderer-neutral palette session tests.") + +(in-suite lime-ui-suite) + +(defun candidate (id label &optional detail result) + (make-ui-candidate :id id :label label :detail detail + :action (lambda () (or result (ui-close-result))))) + +(test direct-search-filters-and-wraps-selection + (let ((session (make-ui-session + (list (candidate "code" "Code" "Lime development") + (candidate "play" "Play" "Game"))))) + (ui-session-handle-key session #\g) + (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session)) + '("play"))) + (is (= (ui-session-selected-index session) 0)) + (ui-session-handle-key session :backspace) + (ui-session-handle-key session :up) + (is (= (ui-session-selected-index session) 1)))) + +(test direct-search-supports-ordered-fuzzy-program-input + (let ((session (make-ui-session + (list (candidate "waterfox" "waterfox") + (candidate "web-browser" "web-browser") + (candidate "terminal" "terminal"))))) + (dolist (character '(#\w #\t #\f)) + (ui-session-handle-key session character)) + (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session)) + '("waterfox"))))) + +(test a-candidate-can-replace-the-palette-with-an-explicit-next-step + (let* ((follow-up (candidate "take" "Move windows here" nil (ui-close-result))) + (session (make-ui-session + (list (candidate "docs" "Docs" "Lime development" + (ui-replace-result + (list follow-up) + "Docs has windows leased on another Head.")))))) + (let ((result (ui-session-handle-key session :return))) + (is (eq (ui-result-kind result) :replace)) + (is (equal (ui-session-status session) + "Docs has windows leased on another Head.")) + (is (equal (mapcar #'ui-candidate-id (ui-session-candidates session)) + '("take")))))) + +(test escape-closes-a-session-without-running-an-action + (let ((session (make-ui-session (list (candidate "code" "Code"))))) + (is (eq (ui-result-kind (ui-session-handle-key session :escape)) :close)))) + +(test a-candidate-can-collect-a-name-through-a-renderer-neutral-prompt + (let ((submitted-name nil)) + (let ((session + (make-ui-session + (list + (make-ui-candidate + :id :new-activity :label "New named Activity..." + :action + (lambda () + (ui-prompt-result + "New Activity" + (lambda (name) + (setf submitted-name name) + (ui-close-result "Activity created."))))))))) + (is (eq (ui-result-kind (ui-session-handle-key session :return)) :prompt)) + (is (eq (ui-session-mode session) :prompt)) + (is (equal (ui-session-prompt session) "New Activity")) + (is (eq (ui-result-kind (ui-session-handle-key session :return)) :keep-open)) + (is (equal (ui-session-status session) "Input is required.")) + (dolist (character '(#\L #\i #\m #\e)) + (ui-session-handle-key session character)) + (is (eq (ui-result-kind (ui-session-handle-key session :return)) :close)) + (is (equal submitted-name "Lime"))))) + +(test key-path-mode-navigates-a-tree-and-can-return-to-search + (let ((ran-p nil)) + (let* ((run-node (make-ui-key-node :id :run :key #\r :label "Run" + :action (lambda () + (setf ran-p t) + (ui-close-result)))) + (tools-node (make-ui-key-node :id :tools :key #\t :label "Tools" + :children (list run-node))) + (session (make-ui-session (list (candidate "search" "Search")) + :key-path (list tools-node)))) + (is (eq (ui-result-kind (ui-session-handle-key session :tab)) :keep-open)) + (is (eq (ui-session-mode session) :key-path)) + (is (equal (mapcar #'ui-key-node-id (ui-session-key-nodes session)) + '(:tools))) + (ui-session-handle-key session #\t) + (is (equal (mapcar #'ui-key-node-id (ui-session-key-path session)) + '(:tools))) + (is (equal (mapcar #'ui-key-node-id (ui-session-key-nodes session)) + '(:run))) + (ui-session-handle-key session :backspace) + (is-false (ui-session-key-path session)) + (is (eq (ui-result-kind (ui-session-handle-key session #\t)) :keep-open)) + (is (eq (ui-result-kind (ui-session-handle-key session #\r)) :close)) + (is-true ran-p) + (ui-session-handle-key session :tab) + (is (eq (ui-session-mode session) :search))))) + +(test command-map-can-open-without-a-search-list-or-running-an-action + (let* ((runs 0) + (leaf (make-ui-key-node :key #\h :label "Hide" + :action (lambda () (incf runs) (ui-close-result)))) + (root (make-ui-key-node :key #\w :label "Windows" :children (list leaf))) + (session (make-ui-session (list (candidate :all "All commands")) + :key-path (list root) :mode :key-path))) + (is (eq :key-path (ui-session-mode session))) + (is (equal (list root) (ui-session-key-nodes session))) + (is-false (ui-session-candidates session)) + (is (eq :keep-open (ui-result-kind (ui-session-handle-key session :return)))) + (is (= 0 runs)) + (ui-session-handle-key session #\z) + (is (search "not available" (ui-session-status session))) + (is (string= "" (ui-session-query session))) + (ui-session-handle-key session #\w) + (is (equal (list root) (ui-session-key-path session))) + (is (equal (list leaf) (ui-session-key-nodes session))) + (ui-session-handle-key session :page-down) + (is (= 1 (ui-session-key-page session))) + (ui-session-handle-key session :backspace) + (is (= 0 (ui-session-key-page session))) + (is-false (ui-session-key-path session)) + (ui-session-handle-key session #\w) + (is (eq :close (ui-result-kind (ui-session-handle-key session #\h)))) + (is (= 1 runs)))) + +(test search-from-the-menu-restores-the-root-catalog-after-a-temporary-picker + (let* ((all (candidate :all "All commands")) + (choice (candidate :partial "Open partial view")) + (leaf (make-ui-key-node :key #\v :label "Views" + :action (lambda () (ui-replace-result (list choice))))) + (session (make-ui-session (list all) :key-path (list leaf) :mode :key-path))) + (ui-session-handle-key session #\v) + (is (eq :search (ui-session-mode session))) + (is (string= "Type to filter; Enter to choose; Esc to cancel." (ui-session-status session))) + (is (equal (list choice) (ui-session-candidates session))) + (ui-session-handle-key session :tab) + (is (eq :key-path (ui-session-mode session))) + (ui-session-handle-key session #\Space) + (is (eq :search (ui-session-mode session))) + (is (equal (list all) (ui-session-candidates session))) + (ui-session-handle-key session :tab) + (ui-session-handle-key session :tab) + (is (equal (list all) (ui-session-candidates session))))) + +(test a-bound-space-in-a-custom-menu-wins-over-the-search-shortcut + (let* ((ran nil) + (node (make-ui-key-node :key #\Space :label "Custom command" + :action (lambda () (setf ran t) (ui-close-result)))) + (session (make-ui-session nil :key-path (list node) :mode :key-path))) + (is (eq :close (ui-result-kind (ui-session-handle-key session #\Space)))) + (is-true ran))) + +(test menu-name-prompts-keep-spaces-and-dont-let-tab-run-a-command + (let* ((name nil) + (node (make-ui-key-node :key #\n :label "New activity" + :action (lambda () + (ui-prompt-result "Name" + (lambda (input) (setf name input) (ui-close-result)))))) + (session (make-ui-session nil :key-path (list node) :mode :key-path))) + (ui-session-handle-key session #\n) + (is (eq :prompt (ui-session-mode session))) + (is (string= "Enter to confirm; Esc to cancel." (ui-session-status session))) + (dolist (key '(#\M #\y #\Space #\W #\M)) (ui-session-handle-key session key)) + (ui-session-handle-key session :tab) + (is (eq :prompt (ui-session-mode session))) + (is-false name) + (is (eq :close (ui-result-kind (ui-session-handle-key session :return)))) + (is (string= "My WM" name)))) + +(test search-and-keyless-launcher-sessions-keep-their-old-entry-behavior + (let ((session (make-ui-session (list (candidate :terminal "st terminal"))))) + (is (eq :search (ui-session-mode session))) + (ui-session-handle-key session #\s) + (ui-session-handle-key session #\Space) + (is (string= "s " (ui-session-query session))) + (ui-session-handle-key session :tab) + (is (eq :search (ui-session-mode session))) + (is (eq :close (ui-result-kind (ui-session-handle-key session :escape)))))) + +(test pointer-candidate-activation-shares-transitions-and-rejects-stale-hits + (let* ((runs 0) + (choice (make-ui-candidate :label "Choice" + :action (lambda () (incf runs) (ui-close-result)))) + (picker (make-ui-candidate :label "Picker" + :action (lambda () (ui-replace-result (list choice))))) + (session (make-ui-session (list picker)))) + (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice)))) + (is (= 0 runs)) + (is (eq :replace (ui-result-kind (ui-session-activate-candidate session picker)))) + (is (equal (list choice) (ui-session-candidates session))) + (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session picker)))) + (is (eq :close (ui-result-kind (ui-session-activate-candidate session choice)))) + (is (= 1 runs)) + (ui-session-handle-key session #\z) + (is-false (ui-session-candidates session)) + (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice)))) + (is (= 1 runs)) + (ui-session-apply-result session (ui-prompt-result "Name" (lambda (name) + (declare (ignore name)) + (ui-close-result)))) + (is (eq :keep-open (ui-result-kind (ui-session-activate-candidate session choice)))) + (is (eq :prompt (ui-session-mode session))))) + +(defun run-tests () + (run! 'lime-ui-suite)) diff --git a/test/x11-activity-navigation.lisp b/test/x11-activity-navigation.lisp new file mode 100644 index 0000000..4349747 --- /dev/null +++ b/test/x11-activity-navigation.lisp @@ -0,0 +1,109 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(test activity-portability-is-default-and-extended-intent-is-sticky + (with-membership-backend (backend world) + (let ((development (current-presentation world "main")) (chill (current-presentation world "other"))) + (is (eq :portable (backend-activity-navigation-mode backend "development"))) + (backend-switch-to-activity backend "chill" :head-id "main") + (is (eq chill (current-presentation world "main"))) + (is (eq development (current-presentation world "other"))) + (is (equal "main" (x11-backend-focused-head-id backend))) + (backend-switch-to-activity backend "development" :head-id "main") + (is (eq development (current-presentation world "main"))) + (backend-extend-activity-to-head backend "development" "other") + (is (eq :extended (backend-activity-navigation-mode backend "development"))) + (is (eq development (current-presentation world "main"))) + (is (null (presentation-client-ids (current-presentation world "other")))) + (backend-switch-to-activity backend "chill" :head-id "other") + (is (eq chill (current-presentation world "other"))) + (is (eq :extended (backend-activity-navigation-mode backend "development"))) + (let ((snapshot (lime.x11::%activity-navigation-snapshot backend))) + (setf (gethash backend lime.x11::*backend-activity-navigation-states*) + (lime.x11::%activity-navigation-read-data snapshot world)) + (is (eq :extended (backend-activity-navigation-mode backend "development")))) + (backend-make-activity-portable backend "development" "main") + (is (eq :portable (backend-activity-navigation-mode backend "development"))) + (is (validate-world world))))) + +(test old-empty-drafts-do-not-anchor-a-portable-activity-to-a-monitor + (with-membership-backend (backend world) + (let* ((primary (current-presentation world "main")) + (old-empty (open-activity-draft world "other" "development"))) + (open-activity-draft world "other" "chill") + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :portable (backend-activity-navigation-mode backend "development"))) + (is (equalp before (lime.persistence:snapshot-world world)))) + (backend-switch-to-activity backend "development" :head-id "other") + (is (eq primary (current-presentation world "other"))) + (is (not (eq old-empty (current-presentation world "other")))) + (is (= 3 (hash-table-count (lime.core::world-presentations world)))) + (is (validate-world world)) + (dotimes (i 10) + (backend-switch-to-activity backend "development" :head-id (if (evenp i) "main" "other")) + (is (eq :portable (backend-activity-navigation-mode backend "development"))) + (is (validate-world world)))))) + +(test explicit-extension-and-collapse-ui-check-stale-contexts + (with-membership-backend (backend world) + (let* ((result (lime.x11::%ui-extend-activity-result backend)) + (choice (second (ui-result-candidates result))) + (before (lime.persistence:snapshot-world world))) + (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result))))) + (is (equalp before (lime.persistence:snapshot-world world))) + (backend-hide-client backend "editor") + (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action choice))))) + (is (eq :portable (backend-activity-navigation-mode backend "development")))) + (backend-extend-activity-to-head backend "development" "other") + (let ((before (lime.persistence:snapshot-world world))) + (signals invalid-transition (backend-make-activity-portable backend "development" "main")) + (is (equalp before (lime.persistence:snapshot-world world))) + (signals stale-transition-plan + (backend-extend-activity-to-head backend "chill" "main" :expected-revision -1)) + (is (equalp before (lime.persistence:snapshot-world world)))))) + +(test portable-policy-validation-and-sending-to-suspended-arrangement + (with-membership-backend (backend world) + (let* ((chill (current-presentation world "other")) + (data (lime.x11::%activity-navigation-snapshot backend))) + (dolist (bad (list (append data (list (first data))) + '(("development" :unknown nil) ("chill" :portable nil)) + `(("development" :portable ,(presentation-id chill)) ("chill" :portable nil)) + '(("development" :extended nil)))) + (signals error (lime.x11::%activity-navigation-read-data bad world))) + (commit-head-topology-reconciliation-plan world + (build-head-topology-reconciliation-plan (preflight-head-topology-reconciliation world '("main")))) + (backend-move-client-to-activity backend "editor" "chill") + (is (equal '("editor") (presentation-client-ids chill))) + (is (null (lease-for-client world "editor"))) + (is (eq :portable (backend-activity-navigation-mode backend "chill"))) + (backend-switch-to-activity backend "chill" :head-id "main") + (is (eq chill (current-presentation world "main"))) + (is (validate-world world))))) + +(test portable-checkpoint-recall-preflights-before-moving-any-monitor + (with-membership-backend (backend world) + (let* ((development (current-presentation world "main")) + (chill (current-presentation world "other"))) + (create-view world "development/alternate" "development" "Alternate" + (list (make-placement :client-id "editor"))) + (backend-activate-view backend "development/alternate" :head-id "other") + (is (eq development (current-presentation world "other"))) + (is (eq chill (current-presentation world "main"))) + (is (eq :portable (backend-activity-navigation-mode backend "development"))) + (is (equal '("editor") (presentation-client-ids development))) + (set-client-shared world "terminal" t) + (show-client-on-presentation world "terminal" (presentation-id chill)) + (create-view world "development/contested" "development" "Contested" + (list (make-placement :client-id "terminal"))) + (let ((before (lime.persistence:snapshot-world world))) + (is (not (activation-report-ready-p + (backend-preflight-view-activation backend "development/contested" :head-id "main")))) + (signals activation-blocked + (backend-activate-view backend "development/contested" :head-id "main")) + (is (equalp before (lime.persistence:snapshot-world world)))) + (backend-activate-view backend "development/contested" :head-id "main" :policy :partial) + (is (eq development (current-presentation world "main"))) + (is (eq chill (current-presentation world "other"))) + (is (equal "other" (presentation-head-id (find-presentation world (lease-presentation-id (lease-for-client world "terminal")))))) + (is (validate-world world))))) diff --git a/test/x11-appearance-config.lisp b/test/x11-appearance-config.lisp new file mode 100644 index 0000000..0cd0dad --- /dev/null +++ b/test/x11-appearance-config.lisp @@ -0,0 +1,8 @@ +(in-package #:cl-user) + +;; A standalone smoke fixture, independent of the user's installed config. +(lime.config:defconfiguration appearance-smoke-config + (:options :default-layout :manual) + (:bar :height 22) + (:appearance :border-width 3 :inner-gap 5 :outer-gap 5 + :focused-border "#ffac54" :unfocused-border "#121f25")) diff --git a/test/x11-appearance-smoke.lisp b/test/x11-appearance-smoke.lisp new file mode 100644 index 0000000..24a868b --- /dev/null +++ b/test/x11-appearance-smoke.lisp @@ -0,0 +1,415 @@ +;;;; Opt-in real-X regression test; requires Xvfb and local Lisp dependencies. +;;;; Run from any directory: sbcl --non-interactive --load /path/to/this/file +;;;; Uses a fresh server selected by -displayfd, never the current DISPLAY. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(let ((server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) + (client-display nil) + (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number))) + (setf backend (lime.x11:start-lime + :display-name display-name :head-discovery :none + :config-file (asdf:system-relative-pathname + "lime" "test/x11-appearance-config.lisp")) + client-display (xlib:open-default-display display-name)) + (let* ((display (lime.x11::x11-backend-display backend)) + (root (lime.x11::x11-backend-root backend)) + (client-root (xlib:screen-root (xlib:display-default-screen client-display))) + (windows (loop repeat 3 collect + (xlib:create-window :parent client-root :x 0 :y 0 + :width 100 :height 100 :border-width 7 + :background 0))) + (ids nil)) + (labels ((check (truth label) + (assert truth () "Failed: ~A" label) + (incf checks)) + (sync () (xlib:display-finish-output display)) + (check-single-tile (window) + (sync) + (check (= 0 (xlib:drawable-border-width window)) "single tile border") + (check (= 0 (xlib:drawable-x window)) "single tile x") + (check (= 22 (xlib:drawable-y window)) "single tile keeps bar") + (check (= 1000 (xlib:drawable-width window)) "single tile width") + (check (= 600 (xlib:drawable-height window)) "single tile height")) + (drain-unmap-events () + ;; This fixture calls commands directly, without the + ;; event loop. Consume real hides from monocle cycling + ;; before testing a later application withdrawal. + (sync) + (loop while + (xlib:event-case (display :timeout 0 :discard-p t) + (:unmap-notify (event-window window configure-p) + (lime.x11::%handle-unmap-notify + backend event-window window configure-p) + t) + (otherwise () t)))) + (pixel-at-border (window) + (sync) + (aref (xlib:image-z-pixarray + (xlib:get-image root :x (xlib:drawable-x window) + :y (+ 10 (xlib:drawable-y window)) + :width 1 :height 1 :format :z-pixmap)) 0 0)) + (border-is (window color) + (check (= (pixel-at-border window) + (lime.x11::%border-pixel backend color)) color))) + (xlib:display-finish-output client-display) + (xlib:change-property (first windows) :_NET_WM_NAME + (babel:string-to-octets "Already named" :encoding :utf-8) + :UTF8_STRING 8) + (xlib:display-finish-output client-display) + (dolist (window windows) + (push (lime.x11:manage-window + backend (find (xlib:window-id window) (xlib:query-tree root) + :key #'xlib:window-id)) ids) + (when (= 1 (length ids)) + (check (string= "Already named" + (lime.x11:icccm-client-info-title + (lime.x11:backend-client-icccm-info backend (first ids)))) + "adoption reads an existing modern title") + ;; First MapRequest in the initial manual draft, then in + ;; master/stack, must already be undecorated. + (check-single-tile window) + (lime.x11:backend-use-master-stack-layout backend) + (check-single-tile window) + (lime.x11:backend-use-manual-layout backend)) + (when (= 2 (length ids)) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) + "second MapRequest restores first tile border") + (check (= 3 (xlib:drawable-border-width window)) + "second MapRequest decorates new tile"))) + (setf ids (nreverse ids)) + (dolist (layout-command (list #'lime.x11:backend-use-manual-layout + #'lime.x11:backend-use-master-stack-layout)) + (funcall layout-command backend) + (lime.x11:backend-hide-client backend (second ids)) + (lime.x11:backend-hide-client backend (third ids)) + (check-single-tile (first windows)) + (lime.x11:backend-show-client + backend (third ids) :kind :float + :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2)) + (check-single-tile (first windows)) + (check (= 3 (xlib:drawable-border-width (third windows))) + "floating overlay keeps border above sole tile") + (lime.x11:backend-toggle-client-floating backend (third ids)) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) + "unfloating restores tiled border") + (check (= 5 (xlib:drawable-x (first windows))) + "unfloating restores outer gap") + (lime.x11:backend-hide-client backend (third ids)) + (lime.x11:backend-show-client backend (second ids)) + (lime.x11:backend-show-client backend (third ids))) + (lime.x11:backend-use-master-stack-layout backend) + (sync) + ;; Real-font metrics, not an assumed number of pixels per glyph, + ;; must position both painted controls and their click regions. + (let* ((head-id (first (lime.x11:backend-head-ids backend))) + (bar (gethash head-id (lime.x11::x11-backend-head-bars backend))) + (font (lime.x11::x11-head-bar-font bar)) + (bar-window (lime.x11::x11-head-bar-window bar)) + (regions (lime.x11::x11-head-bar-hit-regions bar)) + (logo-right (+ 10 (lime.x11::%text-width font "Lime"))) + (layout-left (+ logo-right (lime.x11::%text-width font " | ") + (lime.x11::%text-width font + (lime.x11::%bar-presentation-label backend head-id)) + (lime.x11::%text-width font " | "))) + (layout-right (+ layout-left (lime.x11::%text-width font "[]="))) + (clicks 0)) + (check (= logo-right (lime.x11::x11-head-bar-hit-region-right (first regions))) + "logo uses actual font width") + (check (= layout-left (lime.x11::x11-head-bar-hit-region-left (third regions))) + "layout follows measured label and separator") + (check (= layout-right (lime.x11::x11-head-bar-hit-region-right (third regions))) + "layout click width equals rendered token width") + (let* ((activity-region (second regions)) + (left (lime.x11::x11-head-bar-hit-region-left activity-region)) + (pixels (xlib:image-z-pixarray + (xlib:get-image bar-window :x left :y 0 + :width (- (lime.x11::x11-head-bar-hit-region-right activity-region) left) + :height 22 :format :z-pixmap)))) + (check (loop for i below (array-total-size pixels) + thereis (= (lime.x11::%bar-pixel bar "#ffac54") (row-major-aref pixels i))) + "active Activity text is painted in the accent color")) + (let ((pixels (xlib:image-z-pixarray + (xlib:get-image bar-window :x layout-left :y 0 + :width (- layout-right layout-left) + :height 18 :format :z-pixmap)))) + (check (loop for i below (array-total-size pixels) + thereis (= (lime.x11::%bar-pixel bar "#ffdbb0") + (row-major-aref pixels i))) + "layout text is painted within measured region")) + ;; Inspect actual pixels, not only computed drawing positions. + (labels ((bar-pixel-at (x) + (sync) + (aref (xlib:image-z-pixarray + (xlib:get-image bar-window :x x :y 0 + :width 1 :height 1 :format :z-pixmap)) 0 0)) + (bar-image () + (sync) + (xlib:image-z-pixarray + (xlib:get-image bar-window :x 0 :y 0 :width 1000 :height 22 + :format :z-pixmap))) + (drain-properties () + (xlib:display-finish-output client-display) + (sync) + (loop while + (xlib:event-case (display :timeout 0 :discard-p t) + (:property-notify (window atom) + (lime.x11::%handle-property-notify backend window atom) t) + (:unmap-notify (event-window window configure-p) + (lime.x11::%handle-unmap-notify backend event-window window configure-p) t) + (otherwise () t))))) + (let* ((title-left (+ layout-right 8)) + (saved-config (lime.x11:x11-backend-configuration backend)) + (alternative (lime.x11::copy-lime-configuration saved-config))) + (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d")) + "left title edge is the muted color") + (check (= (bar-pixel-at 999) (bar-pixel-at title-left)) + "right title edge matches the left") + (check (= (bar-pixel-at (1+ title-left)) (lime.x11::%bar-pixel bar "#121f25")) + "title edge is exactly one pixel") + (check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#121f25")) + "focused title has its own background") + (setf (lime.x11::x11-backend-focused-head-id backend) nil) + (lime.x11::render-head-bars backend) + (check (= (bar-pixel-at 998) (lime.x11::%bar-pixel bar "#0b1216")) + "unfocused title background is quieter") + (check (= (bar-pixel-at 0) (lime.x11::%bar-pixel bar "#060a0c")) + "head focus does not recolor the side sections") + (setf (lime.x11::x11-backend-focused-head-id backend) head-id) + (setf (lime.x11:lime-configuration-bar-style alternative) + (lime.x11:make-head-bar-style :title-edge-color nil)) + (lime.x11:apply-lime-configuration backend alternative) + (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#121f25")) + "configuration can remove title edges live") + (lime.x11:apply-lime-configuration + backend saved-config + :source (namestring (asdf:system-relative-pathname "lime" "test/x11-appearance-config.lisp")) + :name 'cl-user::appearance-smoke-config) + (check (= (bar-pixel-at title-left) (lime.x11::%bar-pixel bar "#40535d")) + "restoring configuration repaints title edges")) + (let* ((client (third windows)) + (client-id (third ids)) + (presentation (lime.core:current-presentation + (lime.x11::x11-backend-world backend) head-id)) + (dirty-before (lime.core:presentation-dirty-p presentation))) + (setf (xlib:wm-name client) "Legacy title") + (drain-properties) + (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id)) + "legacy title notification refreshes the cache") + (let ((before (bar-image))) + (xlib:change-property client :_NET_WM_NAME + (babel:string-to-octets "café — Editor" :encoding :utf-8) + :UTF8_STRING 8) + (drain-properties) + (check (string= "café — Editor" (lime.x11::%bar-focused-title backend head-id)) + "modern UTF-8 title wins over legacy title") + (check (not (equalp before (bar-image))) "title notification repaints actual bar pixels")) + (xlib:change-property client :_NET_WM_NAME '(255 65) :UTF8_STRING 8) + (drain-properties) + (check (find #\A (lime.x11::%bar-focused-title backend head-id)) + "malformed UTF-8 does not lose the remaining title") + (xlib:change-property client :_NET_WM_NAME '(1000) :UTF8_STRING 32) + (drain-properties) + (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id)) + "wrong-format modern title falls back safely") + (xlib:change-property client :_NET_WM_NAME '(65) :STRING 8) + (drain-properties) + (check (string= "Legacy title" (lime.x11::%bar-focused-title backend head-id)) + "wrong-type modern title falls back safely") + (xlib:change-property client :WM_NAME '(99 97 102 233) :STRING 8) + (xlib:change-property client :_NET_WM_NAME '() :UTF8_STRING 8) + (drain-properties) + (check (string= "café" (lime.x11::%bar-focused-title backend head-id)) + "empty modern title falls back to Latin-1 legacy title") + (xlib:delete-property client :_NET_WM_NAME) + (drain-properties) + (check (string= "café" (lime.x11::%bar-focused-title backend head-id)) + "deleting modern title immediately restores legacy title") + (xlib:delete-property client :_NET_WM_NAME) + (xlib:delete-property client :WM_NAME) + (xlib:set-wm-class client "editor" "ExampleEditor") + (drain-properties) + (check (string= "ExampleEditor" (lime.x11::%bar-focused-title backend head-id)) + "title deletion falls back to class, not XID") + (check (eq :normal (lime.x11:icccm-client-info-wm-state + (lime.x11:backend-client-icccm-info backend client-id))) + "title updates preserve renderer WM_STATE") + (check (eql dirty-before (lime.core:presentation-dirty-p presentation)) + "title refresh never dirties the draft"))) + ;; Check right alignment and real dispatch of segment hits. + (lime.x11:backend-set-head-bar-status-providers + backend (list (lambda (ignored-backend ignored-head) + (declare (ignore ignored-backend ignored-head)) + (list (lime.x11:make-head-bar-segment + :text "Music" :click-action + (lambda (&rest ignored) (declare (ignore ignored)) (incf clicks))) + (lime.x11:make-head-bar-segment :text "20:00"))))) + (sync) + (let* ((status-left (- 1000 10 (lime.x11::%text-width font "Music | 20:00"))) + (status-right (+ status-left (lime.x11::%text-width font "Music"))) + (region (car (last (lime.x11::x11-head-bar-hit-regions bar))))) + (check (= status-left (lime.x11::x11-head-bar-hit-region-left region)) + "status right alignment uses actual font") + (check (= status-right (lime.x11::x11-head-bar-hit-region-right region)) + "status click excludes separator") + (let* ((separator-width (lime.x11::%text-width font " | ")) + (expected (lime.x11::%make-ui-canvas separator-width 22)) + (pixels (xlib:image-z-pixarray + (xlib:get-image bar-window :x status-right :y 0 + :width separator-width + :height 22 :format :z-pixmap)))) + ;; Thin antialiased strokes need not contain a fully opaque + ;; foreground pixel. Compare the whole expected paint instead. + (unwind-protect + (progn + (lime.x11::%canvas-rectangle expected 0 0 separator-width 22 "#060a0c") + (lime.x11::%canvas-text expected font " | " 0 0 separator-width 22 "#b88755" + :baseline (lime.x11::%font-centered-baseline font 22)) + (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface expected)) + (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface expected))) + (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface expected)))) + (check (loop for y below 22 always + (loop for x below separator-width always + (= (aref pixels y x) + (logand #xffffff (cffi:mem-ref data :uint32 + (+ (* y stride) (* x 4))))))) + "status delimiter has its own antialiased color"))) + (lime.x11::%free-ui-canvas expected))) + (lime.x11::%handle-head-bar-button-press backend bar-window status-left 5 1 0 0) + (check (= 1 clicks) "status text dispatches click") + (lime.x11::%handle-head-bar-button-press backend bar-window status-right 5 1 0 0) + (check (= 1 clicks) "separator does not dispatch click")) + (lime.x11:backend-set-head-bar-status-providers backend nil) + (lime.x11:backend-focus-client backend (third ids))) + (check (= 3 (xlib:drawable-border-width (first windows))) "actual border width") + (check (= 5 (xlib:drawable-x (first windows))) "left gap") + (check (= 27 (xlib:drawable-y (first windows))) "bar and top gap") + (check (= 5 (- (xlib:drawable-x (second windows)) + (+ (xlib:drawable-x (first windows)) + (xlib:drawable-width (first windows)) 6))) "column gap") + (check (= 5 (- (xlib:drawable-y (third windows)) + (+ (xlib:drawable-y (second windows)) + (xlib:drawable-height (second windows)) 6))) "row gap") + (border-is (first windows) "#121f25") + (border-is (third windows) "#ffac54") + (lime.x11:backend-focus-client backend (first ids)) + (lime.x11:backend-use-monocle-layout backend) + (sync) + (check (= 0 (xlib:drawable-border-width (first windows))) "monocle border") + (check (= 0 (xlib:drawable-x (first windows))) "monocle x") + (check (= 22 (xlib:drawable-y (first windows))) "monocle keeps bar") + (check (= 1000 (xlib:drawable-width (first windows))) "monocle width") + (check (= 600 (xlib:drawable-height (first windows))) "monocle height") + (lime.x11:backend-focus-client backend (second ids)) + (sync) + (check (= 0 (xlib:drawable-border-width (second windows))) "cycled monocle border") + (lime.x11:backend-focus-client backend (first ids)) + (lime.x11:backend-use-master-stack-layout backend) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) "restore tiled border") + (check (= 5 (xlib:drawable-x (first windows))) "restore tiled gap") + (border-is (first windows) "#ffac54") + (border-is (third windows) "#121f25") + (lime.x11:backend-focus-head-background backend (first (lime.x11:backend-head-ids backend))) + (border-is (first windows) "#121f25") + (lime.x11:backend-focus-client backend (first ids)) + (lime.x11:backend-set-client-fullscreen backend (first ids) t) + (sync) + (check (= 0 (xlib:drawable-border-width (first windows))) "fullscreen border") + (check (= 0 (xlib:drawable-x (first windows))) "fullscreen x") + (check (= 0 (xlib:drawable-y (first windows))) "fullscreen y") + (check (= 1000 (xlib:drawable-width (first windows))) "fullscreen width") + (check (= 622 (xlib:drawable-height (first windows))) "fullscreen height") + (lime.x11:backend-set-client-fullscreen backend (first ids) nil) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) "restore border") + (border-is (first windows) "#ffac54") + ;; Exercise a failed install after it already repainted windows. + (let* ((old (lime.x11:x11-backend-configuration backend)) + (bad (lime.x11::copy-lime-configuration old)) + (failed nil)) + (setf (lime.x11:lime-configuration-bar-style bad) + (lime.x11:make-head-bar-style :focused-background "#112233" + :title-edge-color "#abcdef") + (lime.x11:lime-configuration-appearance bad) + (lime.x11:make-window-appearance :border-width 9 + :focused-border "#123456" + :unfocused-border "#abcdef") + (lime.x11:lime-configuration-startup-hooks bad) + (list (lambda (ignored) (declare (ignore ignored)) + (error "Deliberate rollback test")))) + (handler-case + (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t) + (error () (setf failed t))) + (check failed "rollback condition") + (check (eq old (lime.x11:x11-backend-configuration backend)) "old config restored") + (sync) + (let* ((head-id (first (lime.x11:backend-head-ids backend))) + (bar (gethash head-id (lime.x11::x11-backend-head-bars backend))) + (window (lime.x11::x11-head-bar-window bar)) + (pixels (xlib:image-z-pixarray + (xlib:get-image window :x 998 :y 0 :width 2 :height 1 + :format :z-pixmap)))) + (check (= (aref pixels 0 0) (lime.x11::%bar-pixel bar "#121f25")) + "failed config restores previous title background") + (check (= (aref pixels 0 1) (lime.x11::%bar-pixel bar "#40535d")) + "failed config restores previous title edge") + (check (null (gethash "#112233" (lime.x11::x11-head-bar-colors bar))) + "rollback releases unused bar colors")) + (check (= 3 (xlib:drawable-border-width (first windows))) "rollback geometry") + (border-is (first windows) "#ffac54") + (check (= 2 (hash-table-count (lime.x11::x11-backend-border-colors backend))) + "unused colors released")) + ;; A successful install and a file reload repaint existing clients. + (let ((new (lime.x11::copy-lime-configuration + (lime.x11:x11-backend-configuration backend)))) + (setf (lime.x11:lime-configuration-appearance new) + (lime.x11:make-window-appearance :border-width 2 :outer-gap 10 + :inner-gap 8 :focused-border "#00ff00")) + (lime.x11:apply-lime-configuration + backend new :source (lime.x11:x11-backend-configuration-source backend) + :name (lime.x11:x11-backend-configuration-name backend)) + (sync) + (check (= 2 (xlib:drawable-border-width (first windows))) "live width update") + (check (= 10 (xlib:drawable-x (first windows))) "live gap update") + (border-is (first windows) "#00ff00")) + (lime.x11:reload-backend-configuration backend) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) "file reload border") + (check (= 5 (xlib:drawable-x (first windows))) "file reload gap") + (border-is (first windows) "#ffac54") + (lime.x11:backend-toggle-focused-client-floating + backend :data '(:x 0 :y 0 :width 1/3 :height 1/3)) + (sync) + (check (= 3 (xlib:drawable-border-width (first windows))) "float border") + (check (= 0 (xlib:drawable-x (first windows))) "float no gap") + (check (= 22 (xlib:drawable-y (first windows))) "float work area") + ;; Withdrawal restores app-owned width before forgetting it. + (drain-unmap-events) + (xlib:unmap-window (first windows)) + (xlib:display-finish-output client-display) + (lime.x11::%handle-unmap-notify + backend root + (gethash (first ids) (lime.x11::x11-backend-client-windows backend)) nil) + (sync) + (check (= 7 (xlib:drawable-border-width (first windows))) "withdrawal original width") + (lime.x11:stop-backend backend) + (setf backend nil) + ;; Roundtrip on the other connection after WM disconnect. + (xlib:display-finish-output client-display) + (dolist (window (rest windows)) + (check (= 7 (xlib:drawable-border-width window)) "shutdown original width")) + (format t "~&Live X11 appearance smoke: ~D checks passed.~%" checks)))) + (when backend (lime.x11:stop-backend backend)) + (when client-display (xlib:close-display client-display)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-attention-smoke.lisp b/test/x11-attention-smoke.lisp new file mode 100644 index 0000000..2e182ec --- /dev/null +++ b/test/x11-attention-smoke.lisp @@ -0,0 +1,233 @@ +;;;; Real ICCCM/EWMH events on an owned Xvfb; never touches the user's DISPLAY. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(handler-case + (let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x600x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number))) + (setf backend (lime.x11:start-lime + :display-name display-name :install-default-keybindings-p nil + :heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 600) + (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 600))) + clients (xlib:open-default-display display-name)) + (let* ((display (lime.x11::x11-backend-display backend)) + (root (xlib:screen-root (xlib:display-default-screen clients))) + (a (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)) + (b (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)) + (aid nil) (bid nil)) + (labels ((check (truth label) (assert truth () "Attention: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (needs (id) (lime.x11:backend-client-needs-attention-p backend id)) + (focused () (xlib:window-id (xlib:input-focus clients))) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0)) + (lime.x11:run-event-loop + backend :timeout 0.005 + :before-event + (lambda (b) + (assert (< (incf turns) 400) () "Attention event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (hints (w urgent &optional (input 1)) + (xlib:change-property w :WM_HINTS (list (+ 3 (if urgent 256 0)) input 1 0 0 0 0 0 0) :WM_HINTS 32) + (pump)) + (state (w action &optional (first :_NET_WM_STATE_DEMANDS_ATTENTION) second) + (xlib:send-event root :client-message '(:substructure-redirect :substructure-notify) + :window w :type :_NET_WM_STATE :format 32 + :data (list action (xlib:intern-atom clients first) + (if second (xlib:intern-atom clients second) 0) 1 0)) + (pump)) + (atoms (w) (xlib:get-property w :_NET_WM_STATE :type :ATOM)) + (has-atom (w name) (member (xlib:intern-atom clients name) (atoms w))) + (key (key) (lime.x11::%perform-ui-action backend (list :key key)) (pump)) + (visit (id) + (lime.x11:backend-open-attention-picker backend) + (let ((candidate (find (list :attend-client id) + (lime.ui:ui-session-candidates (lime.x11::x11-backend-ui-session backend)) + :key #'lime.ui:ui-candidate-id :test #'equal))) + (check candidate "visit target appears in picker") + (lime.x11::%perform-ui-action backend (list :candidate candidate))) + (pump)) + (adopt (w) + (xlib:display-finish-output clients) + (prog1 (lime.x11:manage-window backend (xlib::lookup-window display (xlib:window-id w))) + (pump)))) + (lime.x11:backend-start-activity backend "work" "Work") + (xlib:change-property a :_NET_WM_NAME (babel:string-to-octets "Urgent 日本語" :encoding :utf-8) :UTF8_STRING 8) + (setf aid (adopt a) bid (adopt b)) + (check (= (focused) (xlib:window-id b)) "new client B focused") + (check (member (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION) + (xlib:get-property root :_NET_SUPPORTED)) "EWMH support advertised") + (let ((snapshot (lime.persistence:snapshot-world (world)))) + (hints a t) + (check (needs aid) "ICCCM urgency noticed") + (check (= (focused) (xlib:window-id b)) "urgency never steals focus") + (check (equal snapshot (lime.persistence:snapshot-world (world))) "hint does not dirty or persist model state")) + (check (string= "! 1" (lime.x11:head-bar-segment-text (lime.x11::%bar-attention-segment backend))) "bar counts urgent window") + (hints b t) + (check (not (needs bid)) "already attended client acknowledged") + (check (= 3 (first (xlib:get-property b :WM_HINTS))) "only urgency bit cleared") + (check (= 1 (second (xlib:get-property b :WM_HINTS))) "InputHint preserved") + ;; Two independent sources must not clear one another. + (state a 1) + (check (equal (list aid) (lime.x11:backend-attention-client-ids backend)) "deduplicated two-source count") + (state a 0) + (check (needs aid) "removing EWMH request leaves ICCCM urgency") + (hints a nil) + (check (not (needs aid)) "client cancellation clears last source") + (state a 2) + (check (needs aid) "EWMH toggle adds") + (state a 2) + (check (not (needs aid)) "EWMH toggle removes") + (state a 9) + (check (not (needs aid)) "invalid action ignored") + (state a 1 :_NET_WM_STATE_ABOVE :_NET_WM_STATE_DEMANDS_ATTENTION) + (check (needs aid) "second atom in message supported") + (state a 0) + (state a 2 :_NET_WM_STATE_DEMANDS_ATTENTION :_NET_WM_STATE_DEMANDS_ATTENTION) + (check (needs aid) "duplicate toggle applied once") + (lime.x11:backend-use-monocle-layout backend) + (pump) + (check (eq :unmapped (xlib:window-map-state a)) "non-selected monocle member stays hidden") + (check (needs aid) "monocle hiding does not acknowledge") + (visit aid) + (check (= (focused) (xlib:window-id a)) "attention visit selects monocle member") + (check (not (needs aid)) "visible monocle member acknowledged") + (lime.x11:backend-use-master-stack-layout backend) + (lime.x11:backend-focus-client backend bid :head-id "left") + (state a 1) + ;; Hidden, then inactive Activity: no automatic reveal. + (lime.x11:backend-hide-client backend aid) + (pump) + (check (eq :unmapped (xlib:window-map-state a)) "urgent window can stay hidden") + (lime.x11:backend-start-activity backend "chill" "Chill") + (pump) + (check (needs aid) "inactive Activity remains discoverable") + (check (string= "Work: Urgent 日本語" + (lime.ui:ui-candidate-label (first (lime.x11::%ui-attention-candidates backend)))) "picker identifies task and live title") + ;; The real bar event path opens the picker without dismissing it. + (let* ((bar (gethash "left" (lime.x11::x11-backend-head-bars backend))) + (region (car (last (lime.x11::x11-head-bar-hit-regions bar)))) + (x (floor (+ (lime.x11::x11-head-bar-hit-region-left region) + (lime.x11::x11-head-bar-hit-region-right region)) 2))) + (xlib/xtest:fake-motion-event display x 10) + (xlib/xtest:fake-button-event display 1 t) + (xlib/xtest:fake-button-event display 1 nil) + (pump) + (check (lime.x11:backend-command-palette-open-p backend) "clickable badge opens picker") + (check (needs aid) "opening picker does not acknowledge") + (key :escape) + (check (needs aid) "cancelling picker leaves parked request")) + (lime.x11:backend-open-command-palette backend) + (key #\w) (key #\a) + (check (eq :search (lime.ui:ui-session-mode (lime.x11::x11-backend-ui-session backend))) "w a enters attention search") + (key :return) + (check (not (lime.x11:backend-command-palette-open-p backend)) "visit closes picker") + (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "visit returns to owning Activity") + (check (= (focused) (xlib:window-id a)) "hidden target revealed and focused") + (check (not (needs aid)) "visit acknowledges after menu grab ends") + (lime.x11:backend-set-client-fullscreen backend bid t) + (state a 1) + (visit aid) + (check (= (focused) (xlib:window-id a)) "explicit visit escapes a different fullscreen window") + (check (not (has-atom b :_NET_WM_STATE_FULLSCREEN)) "masking fullscreen exited only on user visit") + ;; Actual focus matters: root background and another Head's saved + ;; focus are not acknowledgement. + (lime.x11:backend-focus-head-background backend "left") + (hints a t) + (check (needs aid) "root focus does not acknowledge saved focus") + (lime.x11:backend-focus-client backend bid :head-id "left") + (lime.x11:backend-activate-activity backend "work" :head-id "right") + (lime.x11:backend-show-client-taking backend aid :head-id "right") + (lime.x11:backend-select-head backend "left") + (hints a t) + (check (needs aid) "other Head's current client stays urgent") + (let ((lease (lime.core:lease-presentation-id (lime.core:lease-for-client (world) aid)))) + (visit aid) + (check (equal "right" (lime.x11::x11-backend-focused-head-id backend)) "visit follows existing Head") + (check (equal lease (lime.core:lease-presentation-id (lime.core:lease-for-client (world) aid))) "visit never transfers existing lease") + (check (not (needs aid)) "other Head visit acknowledges")) + ;; Preserve unknown state and fullscreen on acknowledgement. + (lime.x11:backend-select-head backend "left") + (xlib:change-property a :_NET_WM_STATE (list (xlib:intern-atom clients :_TEST_CUSTOM_STATE)) :ATOM 32) + (state a 1 :_NET_WM_STATE_FULLSCREEN :_NET_WM_STATE_DEMANDS_ATTENTION) + ;; Existing fullscreen command may select the requested Head. + ;; Move back, set attention anew, then visit the fullscreen target. + (lime.x11:backend-select-head backend "left") + (state a 1) + (visit aid) + (check (has-atom a :_TEST_CUSTOM_STATE) "unknown state preserved") + (check (has-atom a :_NET_WM_STATE_FULLSCREEN) "fullscreen preserved") + (check (not (has-atom a :_NET_WM_STATE_DEMANDS_ATTENTION)) "only attention state removed") + (lime.x11:backend-set-client-fullscreen backend aid nil) + ;; Globally active clients must actually answer TAKE_FOCUS. + (lime.x11:backend-select-head backend "left") + (hints a nil 0) + (setf (xlib:wm-protocols a) '(:WM_TAKE_FOCUS)) + (pump) + (state a 1) + (lime.x11:backend-attend-client backend aid) + (pump) + (check (needs aid) "unanswered TAKE_FOCUS does not clear attention") + (let ((child (xlib:create-window :parent a :x 0 :y 0 :width 20 :height 20))) + (xlib:map-window child) + (xlib:set-input-focus clients child :pointer-root) + (pump) + (check (not (needs aid)) "async focus to child acknowledges owning client")) + ;; Initial hints, NoInput clients, property deletion and withdrawal. + (let ((c (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100))) + (xlib:change-property c :WM_HINTS '(259 0 1 0 0 0 0 0 0) :WM_HINTS 32) + (xlib:change-property c :_NET_WM_STATE + (list (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION)) :ATOM 32) + (let ((cid (adopt c))) + (check (needs cid) "initial hints adopted; NoInput client not acknowledged") + (check (= 3 (gethash cid (lime.x11::x11-backend-attention-clients backend))) "both initial sources retained") + (xlib:delete-property c :WM_HINTS) + (pump) + (check (= 2 (gethash cid (lime.x11::x11-backend-attention-clients backend))) "deleted WM_HINTS clears only urgency") + (xlib:delete-property c :_NET_WM_STATE) + (pump) + (check (not (needs cid)) "deleted state clears demand") + (xlib:change-property c :_NET_WM_STATE + (list (xlib:intern-atom clients :_NET_WM_STATE_DEMANDS_ATTENTION)) :ATOM 32) + (pump) + (check (needs cid) "direct property change observed without focus") + (xlib:unmap-window c) + (pump) + (check (not (needs cid)) "withdrawal clears attention cache") + (check (null (gethash cid (lime.x11::x11-backend-client-windows backend))) "withdrawal really retires client") + (xlib:destroy-window c) + (pump))) + ;; Hidden _NET_ACTIVE_WINDOW stays hidden but creates attention. + (lime.x11:backend-hide-client backend aid :head-id "right") + (xlib:send-event root :client-message '(:substructure-redirect :substructure-notify) + :window a :type :_NET_ACTIVE_WINDOW :format 32 :data '(1 0 0 0 0)) + (pump) + (check (needs aid) "denied hidden activation becomes attention") + (check (eq :unmapped (xlib:window-map-state a)) "denied activation never reveals window") + ;; Destroy cleans cache and an already-open stale picker stays safe. + (lime.x11:backend-open-attention-picker backend) + (xlib:destroy-window a) + (pump) + (check (not (needs aid)) "destroy clears attention") + (key :return) + (check (lime.x11:backend-command-palette-open-p backend) "stale picker stays open with explanation") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no UI error after stale selection") + (key :escape) + (check (null (lime.x11:backend-attention-client-ids backend)) "no phantom attention remains") + (format t "~&Attention smoke: ~D checks passed.~%" checks)))) + (when backend (ignore-errors (lime.x11:stop-backend backend))) + (when clients (ignore-errors (xlib:close-display clients :abort t))) + (uiop:terminate-process server) + (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Attention smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-attention.lisp b/test/x11-attention.lisp new file mode 100644 index 0000000..e137dad --- /dev/null +++ b/test/x11-attention.lisp @@ -0,0 +1,149 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(test attention-sources-are-independent-live-metadata + (let* ((backend (make-head-bar-fixture)) + (world (x11-backend-world backend)) + (snapshot (lime.persistence:snapshot-world world))) + (is-false (backend-attention-client-ids backend)) + (lime.x11::%attention-set-source backend "browser" 1 t) + (lime.x11::%attention-set-source backend "browser" 2 t) + (is (equal '("browser") (backend-attention-client-ids backend))) + (lime.x11::%attention-set-source backend "browser" 2 nil) + (is-true (backend-client-needs-attention-p backend "browser")) + (lime.x11::%attention-set-source backend "terminal" 2 t) + (is (equal '("browser" "terminal") (backend-attention-client-ids backend))) + (is (equal '("browser" "terminal") + (backend-attention-client-ids backend :activity-id "development"))) + (is-false (backend-attention-client-ids backend :activity-id "other")) + (is (equal snapshot (lime.persistence:snapshot-world world))) + (lime.x11::%attention-set-source backend "browser" 1 nil) + (is-false (backend-client-needs-attention-p backend "browser")) + (is-false (gethash "browser" (lime.x11::x11-backend-attention-clients backend))))) + +(test attention-bar-and-picker-use-cached-data + (let* ((backend (make-head-bar-fixture)) + (info (lime.x11::make-icccm-client-info :title "日本語 browser"))) + (is-false (lime.x11::%bar-attention-segment backend)) + (setf (gethash "browser" (lime.x11::x11-backend-icccm-clients backend)) info) + (lime.x11::%attention-set-source backend "browser" 1 t) + (let ((segment (lime.x11::%bar-attention-segment backend)) + (candidate (first (lime.x11::%ui-attention-candidates backend)))) + (is (eq :attention (head-bar-segment-id segment))) + (is (string= "! 1" (head-bar-segment-text segment))) + (is (functionp (head-bar-segment-click-action segment))) + (is (string= "Development: 日本語 browser" (ui-candidate-label candidate))) + (is (equal '(:attend-client "browser") (ui-candidate-id candidate))) + (is (string= "! Show: 日本語 browser" + (ui-candidate-label (first (lime.x11::%ui-hidden-client-candidates backend))))) + (is (search "! 1" (ui-candidate-detail (first (lime.x11::%ui-activity-candidates backend))))) + ;; A cancelled request leaves a stale menu entry safe and non-mutating. + (lime.x11::%attention-set-source backend "browser" 1 nil) + (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action candidate)))))) + (let* ((window (find :window (lime.x11::%ui-key-path backend) :key #'ui-key-node-id)) + (attention (find :attention (ui-key-node-children window) :key #'ui-key-node-id))) + (is (char= #\a (ui-key-node-key attention)))))) + +(test attention-acknowledgement-requires-selected-visible-input-target + (let* ((backend (make-head-bar-fixture)) + (info (lime.x11::make-icccm-client-info :wm-state :normal))) + (setf (gethash "editor" (lime.x11::x11-backend-icccm-clients backend)) info) + (is-true (lime.x11::%attention-selected-client-p backend "editor")) + (is-false (lime.x11::%attention-selected-client-p backend "terminal")) + (setf (lime.x11::x11-backend-focus-root-override-p backend) t) + (is-false (lime.x11::%attention-selected-client-p backend "editor")) + (setf (lime.x11::x11-backend-focus-root-override-p backend) nil + (lime.x11::x11-backend-ui-session backend) (make-ui-session nil)) + (is-false (lime.x11::%attention-selected-client-p backend "editor")) + (setf (lime.x11::x11-backend-ui-session backend) nil + (lime.x11::icccm-client-info-wm-state info) :iconic) + (is-false (lime.x11::%attention-selected-client-p backend "editor")) + (setf (lime.x11::icccm-client-info-wm-state info) :normal + (icccm-client-info-accepts-input-p info) nil) + (is-false (lime.x11::%attention-selected-client-p backend "editor")))) + +(test attention-style-is-user-owned-and-validated + (let* ((configuration (symbol-value (eval '(lime.config:defconfiguration attention-test-config + (:options :default-keybindings nil) + (:bar :attention-color "#abcdef" :attention-marker "*" + :attention-indicator-p nil))))) + (style (lime-configuration-bar-style configuration)) + (backend (make-head-bar-fixture))) + (is (string= "#abcdef" (head-bar-style-attention-color style))) + (is (string= "*" (head-bar-style-attention-marker style))) + (is-false (head-bar-style-attention-indicator-p style)) + (setf (lime.x11::x11-backend-configuration backend) configuration) + (lime.x11::%attention-set-source backend "browser" 1 t) + (is-false (lime.x11::%bar-attention-segment backend)) + (is (= 1 (length (backend-attention-client-ids backend)))) + (setf (head-bar-style-attention-indicator-p style) t) + (is (string= "* 1" (head-bar-segment-text (lime.x11::%bar-attention-segment backend)))) + (dolist (bad (list (make-head-bar-style :attention-color "bad") + (make-head-bar-style :attention-marker "") + (make-head-bar-style :attention-marker (string #\Newline)) + (make-head-bar-style :attention-indicator-p 1))) + (signals invalid-transition (lime.x11::%validate-head-bar-style bad))))) + +(test attention-visits-respect-collisions-and-stale-choices + (dolist (policy '(:partial :take)) + (declare (ignorable policy)) + (let* ((backend (make-head-bar-fixture)) + (world (x11-backend-world backend)) + (render 'lime.x11:apply-active-presentation) + (old-render (symbol-function render))) + (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-head world "other") + (open-activity-draft world "other" "development") + (unwind-protect + (progn + (setf (symbol-function render) (lambda (b) b)) + (backend-activate-activity backend "development") + (backend-start-activity backend "chill" "Chill") + (backend-show-client backend "terminal" :head-id "other") + (backend-select-head backend "main") + (lime.x11::%attention-set-source backend "browser" 1 t) + (let* ((revision (world-revision world)) + (candidate (find (list :attend-client "browser") + (lime.x11::%ui-attention-candidates backend) + :key #'ui-candidate-id :test #'equal))) + (is-true candidate) + (is (= revision (world-revision world))) + ;; Request cancelled while choosing: no incidental task switch. + (lime.x11::%attention-set-source backend "browser" 1 nil) + (is (eq :keep-open (ui-result-kind (funcall (ui-candidate-action candidate))))) + (is (= revision (world-revision world))) + (lime.x11::%attention-set-source backend "browser" 1 t) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action candidate))))) + (is (equal "browser" (presentation-focus-client-id (current-presentation world "main")))) + (is (equal "other" + (lime.x11::ewmh-active-head-id-for-client backend "terminal"))) + (is (equal '("editor" "terminal") + (mapcar #'placement-client-id (view-placements (find-view world "development/code"))))))) + (setf (symbol-function render) old-render))))) + +(test attention-reclaims-only-the-requested-available-slot + (let* ((backend (make-head-bar-fixture)) + (world (x11-backend-world backend)) + (source (current-presentation world "main")) + (render 'lime.x11:apply-active-presentation) + (old-render (symbol-function render))) + (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-head world "other") + (let ((other (open-activity-draft world "other" "development"))) + (unwind-protect + (progn + (setf (symbol-function render) (lambda (b) b)) + (dolist (id '("editor" "terminal")) + (backend-show-client-taking backend id :head-id "other") + (hide-client-from-presentation world id (presentation-id other))) + (is-false (presentation-client-ids source)) + (backend-select-head backend "main") + (backend-attend-client backend "editor") + (is (equal '("editor") (presentation-client-ids source))) + (is-false (lease-for-client world "terminal")) + (is (equal "editor" (presentation-focus-client-id source)))) + (setf (symbol-function render) old-render))))) diff --git a/test/x11-cursor-smoke.lisp b/test/x11-cursor-smoke.lisp new file mode 100644 index 0000000..9bf01de --- /dev/null +++ b/test/x11-cursor-smoke.lisp @@ -0,0 +1,177 @@ +;;;; Native cursor pixels, reload/rollback, animation, and no-RENDER fallback. +;;;; Own Xvfb only. Adwaita, libXcursor, and test-only libXfixes are required. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(cffi:load-foreign-library "libX11.so.6") +(cffi:load-foreign-library "libXfixes.so.3") +(cffi:defcfun ("XOpenDisplay" cursor-test-open-display) :pointer (name :string)) +(cffi:defcfun ("XCloseDisplay" cursor-test-close-display) :int (display :pointer)) +(cffi:defcfun ("XFree" cursor-test-free) :int (pointer :pointer)) +(cffi:defcfun ("XFixesGetCursorImage" cursor-test-get-image) :pointer (display :pointer)) +(cffi:defcstruct cursor-test-image + (x :short) (y :short) (width :unsigned-short) (height :unsigned-short) + (xhot :unsigned-short) (yhot :unsigned-short) (serial :unsigned-long) + (pixels :pointer) (atom :unsigned-long) (name :pointer)) + +(defun cursor-test-snapshot (display) + (let ((image (cursor-test-get-image display))) + (assert (not (cffi:null-pointer-p image))) + (unwind-protect + (cffi:with-foreign-slots ((width height xhot yhot pixels) image (:struct cursor-test-image)) + (let ((copy (make-array (list height width) :element-type '(unsigned-byte 32)))) + ;; Xlib's 32-bit wire pixels occupy native longs (sign-extended on LP64). + (dotimes (i (* width height)) + (setf (row-major-aref copy i) (logand #xffffffff (cffi:mem-aref pixels :unsigned-long i)))) + (values copy xhot yhot))) + (cursor-test-free image)))) + +(defmacro cursor-test-with-function ((name function) &body body) + (let ((old (gensym "OLD"))) + `(let ((,old (symbol-function ',name))) + (unwind-protect (progn (setf (symbol-function ',name) ,function) ,@body) + (setf (symbol-function ',name) ,old))))) + +(dolist (mode '(24 16 :no-render)) + (let ((server (uiop:launch-program + (append (list "Xvfb" "-displayfd" "1" "-screen" "0" + (format nil "800x600x~D" (if (integerp mode) mode 24)) "-nolisten" "tcp") + (when (eq mode :no-render) '("-extension" "RENDER"))) + :output :stream :error-output :interactive)) + (backend nil) (probe nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (name (format nil ":~D" number)) + (configuration (lime.x11:make-lime-configuration + :cursor (lime.x11:make-ui-cursor-style :theme "Adwaita" :size 24)))) + (setf backend (lime.x11:start-lime :display-name name :head-discovery :none) + probe (cursor-test-open-display name)) + (assert (not (cffi:null-pointer-p probe))) + (let ((display (lime.x11::x11-backend-display backend))) + (labels ((check (truth label) (assert truth () "Cursor ~A: ~A" mode label) (incf checks)) + (sync () (xlib:display-finish-output display)) + (cursor-info () (lime.x11:backend-cursor-report backend)) + (source (role) (getf (getf (cursor-info) role) :source)) + (move (x y) (xlib/xtest:fake-motion-event display x y) (sync)) + (matches (names size) + (let ((frame (first (lime.x11::%load-cursor-frames names "Adwaita" size)))) + (multiple-value-bind (pixels x y) (cursor-test-snapshot probe) + (check (equalp pixels (lime.x11::cursor-frame-pixels frame)) "ARGB pixels match theme file") + (check (= x (lime.x11::cursor-frame-xhot frame)) "x hotspot") + (check (= y (lime.x11::cursor-frame-yhot frame)) "y hotspot"))))) + (lime.x11:apply-lime-configuration backend configuration) + ;; Read actual Xresources from this isolated screen. Avoid any + ;; inherited test-runner environment hiding their precedence. + (lime.x11::%apply-cursor-session-settings backend (lime.x11:make-ui-cursor-style)) + (let ((getenv (symbol-function 'uiop:getenv))) + (xlib:change-property (lime.x11::x11-backend-root backend) :RESOURCE_MANAGER + (map 'vector #'char-code (format nil "Xcursor.theme: Adwaita~%Xcursor.size: 32~%")) + :STRING 8) + (cursor-test-with-function + (uiop:getenv (lambda (name) + (unless (member name '("XCURSOR_THEME" "XCURSOR_SIZE") :test #'string=) + (funcall getenv name)))) + (check (equal '("Adwaita" 32) + (multiple-value-list + (lime.x11::%backend-cursor-settings backend (lime.x11:make-ui-cursor-style)))) + "screen Xresources theme/size resolve")) + (xlib:delete-property (lime.x11::x11-backend-root backend) :RESOURCE_MANAGER)) + (lime.x11::%apply-cursor-session-settings backend (lime.x11:lime-configuration-cursor configuration)) + (move 600 500) + (if (eq mode :no-render) + (progn + (check (eq :core (source :arrow)) "arrow falls back without RENDER") + (check (eq :core (source :hand)) "hand falls back without RENDER") + (check (search "RENDER" (getf (getf (cursor-info) :arrow) :reason)) "fallback reason is inspectable")) + (progn + (check (eq :theme (source :arrow)) "arrow is themed, not silently falling back") + (check (eq :theme (source :hand)) "hand is themed") + (matches '("default" "left_ptr") 24) + ;; A missing requested theme can inherit the system default. + (let ((missing (lime.x11::copy-lime-configuration configuration))) + (setf (lime.x11:lime-configuration-cursor missing) + (lime.x11:make-ui-cursor-style :theme "Lime-Nonexistent-Cursor-Smoke-Theme" :size 24)) + (lime.x11:apply-lime-configuration backend missing) + (check (eq :theme (source :arrow)) "missing theme uses Xcursor's default-theme fallback")))) + ;; Core mode is always a deliberate usable escape hatch. + (let ((core (lime.x11::copy-lime-configuration configuration))) + (setf (lime.x11:lime-configuration-cursor core) (lime.x11:make-ui-cursor-style :theme :core)) + (lime.x11:apply-lime-configuration backend core) + (check (eq :core (source :arrow)) "explicit core mode") + (check (eq :core (source :hand)) "explicit core hand")) + (unless (eq mode :no-render) + (lime.x11:apply-lime-configuration backend configuration) + ;; Shared hand resource must be rebound even while still hovered. + (lime.x11:backend-open-command-palette backend) + (let* ((session (lime.x11::x11-backend-ui-session backend)) + (overlay (lime.x11::x11-backend-ui-overlay backend)) + (window (lime.x11::x11-ui-overlay-window overlay)) + (hit (first (lime.x11::x11-ui-overlay-hit-regions overlay))) + (x (+ (xlib:drawable-x window) (lime.x11::ui-hit-region-x hit) 1)) + (y (+ (xlib:drawable-y window) (lime.x11::ui-hit-region-y hit) 1)) + (large (lime.x11::copy-lime-configuration configuration)) + (old-set (lime.x11::x11-backend-cursor-set backend))) + (move x y) + (lime.x11::%handle-ui-motion backend window x y) + (sync) + (matches '("pointer" "hand2") 24) + (setf (lime.x11:lime-configuration-cursor large) + (lime.x11:make-ui-cursor-style :theme "Adwaita" :size 48)) + (lime.x11:apply-lime-configuration backend large) + (check (eq session (lime.x11::x11-backend-ui-session backend)) "live reload preserves session") + (check (null (lime.x11::x11-cursor-set-arrow old-set)) "old resources released after commit") + (check (= 1 (xlib/xtest:compare-cursor display window + (xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend)))) "hover rebinds new hand XID") + (matches '("pointer" "hand2") 48) + ;; Fail after installing the replacement: restore the exact old XIDs. + (let ((before (lime.x11::x11-backend-cursor-set backend)) + (failed-set nil) (caught nil) + (bad (lime.x11::copy-lime-configuration configuration))) + (setf (lime.x11:lime-configuration-startup-hooks bad) + (list (lambda (backend) + (setf failed-set (lime.x11::x11-backend-cursor-set backend)) + (error "Cursor rollback fixture")))) + (handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t) + (error () (setf caught t))) + (check caught "later config failure is reported") + (check (eq before (lime.x11::x11-backend-cursor-set backend)) "rollback restores original cursor set") + (check (null (lime.x11::x11-cursor-set-hand failed-set)) "failed replacement released") + (check (= 1 (xlib/xtest:compare-cursor display window + (xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend)))) "rollback rebinds hovered UI") + (matches '("pointer" "hand2") 48))) + (lime.x11:backend-close-command-palette backend) + ;; Optional-library failure does not stop the WM. + (cursor-test-with-function (lime.x11::%ensure-cursor-library + (lambda () (error "Library missing fixture"))) + (lime.x11:apply-lime-configuration backend configuration) + (check (eq :core (source :arrow)) "missing library fallback") + (check (search "Library missing" (getf (getf (cursor-info) :arrow) :reason)) "library diagnostic")) + ;; Animated themes are handed to the server, not a polling loop. + (cursor-test-with-function + (lime.x11::%load-cursor-frames + (lambda (&rest args) + (declare (ignore args)) + (values (loop for color in '(#xffff0000 #xff00ff00) collect + (lime.x11::make-cursor-frame + :pixels (make-array '(12 12) :element-type '(unsigned-byte 32) + :initial-element color) + :xhot 1 :yhot 2 :delay 20)) "fixture"))) + (lime.x11:apply-lime-configuration backend configuration) + (check (= 2 (getf (getf (cursor-info) :arrow) :frames)) "animated arrow uploaded") + (move 600 500) + ;; XFixes on Xvfb reports the animation wrapper's 1x1 bits, + ;; not a displayed frame. Verify the live animated XID here; + ;; static pixel/hotspot upload is checked above on both depths. + (check (= 1 (xlib/xtest:compare-cursor + display (lime.x11::x11-backend-root backend) + (xlib:cursor-id (lime.x11::x11-backend-root-cursor backend)))) + "root bound to animated cursor") + (check (= 1 (xlib/xtest:compare-cursor display (lime.x11::x11-backend-root backend))) + "animated cursor is active"))) + (lime.x11:stop-backend backend) + (check (null (lime.x11::x11-backend-cursor-set backend)) "shutdown clears resources") + (format t "~&Live X11 cursor themes (~A): ~D checks passed.~%" mode checks)))) + (when backend (lime.x11:stop-backend backend)) + (when (and probe (not (cffi:null-pointer-p probe))) (cursor-test-close-display probe)) + (uiop:terminate-process server) + (uiop:wait-process server)))) diff --git a/test/x11-cursor.lisp b/test/x11-cursor.lisp new file mode 100644 index 0000000..6f0321c --- /dev/null +++ b/test/x11-cursor.lisp @@ -0,0 +1,36 @@ +(in-package #:lime.x11.test) + +(in-suite lime-x11-suite) + +(test cursor-configuration-validates-before-touching-x + (let ((config (make-lime-configuration))) + (is (typep (lime-configuration-cursor config) 'ui-cursor-style)) + (dolist (theme '(nil :core "Adwaita" "Bibata-Original-Ice")) + (setf (lime-configuration-cursor config) (make-ui-cursor-style :theme theme :size 24)) + (is (eq config (lime.x11::%validate-lime-configuration config)))) + (dolist (theme (list "" " " :unknown 4 (string #\Null))) + (setf (lime-configuration-cursor config) (make-ui-cursor-style :theme theme)) + (signals invalid-transition (lime.x11::%validate-lime-configuration config))) + (dolist (size '(0 -1 7 257 24.0 "24")) + (setf (lime-configuration-cursor config) (make-ui-cursor-style :size size)) + (signals invalid-transition (lime.x11::%validate-lime-configuration config))) + (let ((dsl (find-lime-configuration + (eval '(lime.config:defconfiguration cursor-fixture + (:cursor :theme "Adwaita" :size (+ 16 8))))))) + (is (string= "Adwaita" (ui-cursor-style-theme (lime-configuration-cursor dsl)))) + (is (= 24 (ui-cursor-style-size (lime-configuration-cursor dsl))))) + (signals error (macroexpand-1 '(lime.config:defconfiguration duplicate (:cursor) (:cursor)))) + (signals error (macroexpand-1 '(lime.config:defconfiguration unknown (:cursor :unknown 2)))))) + +(test cursor-system-defaults-and-explicit-overrides + (flet ((resolve (style &rest defaults) + (multiple-value-list (apply #'lime.x11::%resolve-cursor-settings style defaults)))) + (is (equal '("default" 24) (resolve (make-ui-cursor-style) nil nil nil nil nil))) + (is (equal '("Adwaita" 32) (resolve (make-ui-cursor-style) nil nil "Adwaita" "32" nil))) + (is (equal '("env-theme" 48) (resolve (make-ui-cursor-style) "env-theme" "48" "resource-theme" "32" nil))) + (is (equal '("explicit" 24) (resolve (make-ui-cursor-style :theme "explicit" :size 24) + "env-theme" "48" "resource-theme" "32" "192"))) + (is (equal '(:core 24) (resolve (make-ui-cursor-style :theme :core :size 24) + "env-theme" "48" "resource-theme" "32" nil))) + (is (equal '("default" 43) (resolve (make-ui-cursor-style) "" "bad" nil "0" "192"))) + (is (equal '("default" 24) (resolve (make-ui-cursor-style) nil "999999" nil "-32" "bad"))))) diff --git a/test/x11-default-layout-config.lisp b/test/x11-default-layout-config.lisp new file mode 100644 index 0000000..d75bd91 --- /dev/null +++ b/test/x11-default-layout-config.lisp @@ -0,0 +1,16 @@ +(in-package #:cl-user) + +(defvar *default-layout-smoke-loads* 0) +(defvar *default-layout-smoke-startups* 0) +(incf *default-layout-smoke-loads*) + +(lime.config:defconfiguration default-layout-smoke-config + (:options :default-layout :monocle) + (:startup + (lambda (backend) + (dolist (head (lime.x11:backend-head-ids backend)) + (assert (eq :monocle + (lime.core:presentation-layout-mode + (lime.core:current-presentation + (lime.x11::x11-backend-world backend) head))))) + (incf *default-layout-smoke-startups*)))) diff --git a/test/x11-default-layout-smoke.lisp b/test/x11-default-layout-smoke.lisp new file mode 100644 index 0000000..9af6d00 --- /dev/null +++ b/test/x11-default-layout-smoke.lisp @@ -0,0 +1,91 @@ +;;;; Run with sbcl --non-interactive --load test/x11-default-layout-smoke.lisp. +;;;; Owns an isolated Xvfb; never connects to the user's desktop. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(let ((server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x600x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (client-display nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 500 :height 600) + (lime.x11:make-x11-head :head-id "right" :x 500 :y 0 :width 500 :height 600)))) + (labels ((check (truth label) + (assert truth () "Failed: ~A" label) + (incf checks)) + (world () (lime.x11::x11-backend-world backend)) + (current (&optional (head "left")) (lime.core:current-presentation (world) head)) + (mode (&optional (head "left")) (lime.core:presentation-layout-mode (current head)))) + ;; Clients that precede the WM must be adopted into master/stack, + ;; not briefly seeded into a permanent manual draft. + (setf client-display (xlib:open-default-display display-name)) + (let* ((root (xlib:screen-root (xlib:display-default-screen client-display))) + (windows (loop repeat 3 collect + (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)))) + (dolist (window windows) (xlib:map-window window)) + (xlib:display-finish-output client-display) + (setf backend (lime.x11:start-lime :display-name display-name :heads heads + :head-bar-height 0 :install-default-keybindings-p nil)) + (check (eq :master-stack (mode)) "default bootstrap left") + (check (eq :master-stack (mode "right")) "default bootstrap right") + (check (null (lime.core:activity-view-ids (lime.core:find-activity (world) "scratch"))) + "startup does not create saved views") + (check (= 3 (length (lime.core:presentation-client-ids (current)))) "three adopted clients") + (check (= 300 (xlib:drawable-width (first windows))) "master occupies 3/5 of head") + (check (= 200 (xlib:drawable-width (second windows))) "stack occupies 2/5 of head") + (check (= 300 (xlib:drawable-height (third windows))) "stack subdivides vertically") + (lime.x11:backend-adjust-master-stack-ratio backend 1/20) + (check (= 13/20 (getf (lime.core:presentation-layout-options (current)) :master-ratio)) + "initial options support resize commands") + (lime.x11:backend-use-manual-layout backend) + (lime.x11:backend-save-view backend "manual" "Manual") + (let ((before (current))) + (lime.x11:apply-lime-configuration + backend (lime.x11:make-lime-configuration :default-layout :monocle)) + (check (eq before (current)) "configuration retains existing draft object") + (check (eq :manual (mode)) "configuration retains current layout") + (check (eq :master-stack (mode "right")) "configuration retains other head layout")) + (lime.x11:backend-start-activity backend "chill" "Chill") + (check (eq :monocle (mode)) "new activity follows configured default") + (lime.x11:backend-use-master-stack-layout backend) + (lime.x11:backend-activate-activity backend "scratch" :view-id "manual") + (check (eq :manual (mode)) "saved view keeps manual layout") + (lime.x11:backend-activate-activity backend "chill") + (check (eq :master-stack (mode)) "returning to draft retains layout choice") + (let ((report (lime.x11:backend-preflight-activity-activation backend "chill" :head-id "right"))) + (check (eq :monocle (lime.core:activation-report-desired-layout-mode report)) + "first visit on another head preflights default")) + (lime.x11:backend-activate-activity backend "chill" :head-id "right") + (check (eq :monocle (mode "right")) "first visit on another head uses default") + (check (lime.core:validate-world (world)) "world invariants after switches")) + (lime.x11:stop-backend backend) + (setf backend nil) + (xlib:close-display client-display) + (setf client-display nil) + ;; The file must be evaluated once, before initial drafts exist. + ;; Its layout overrides an explicitly conflicting startup keyword. + (setf backend + (lime.x11:start-lime + :display-name display-name :heads heads :head-bar-height 0 + :default-layout :manual + :config-file (asdf:system-relative-pathname "lime" "test/x11-default-layout-config.lisp"))) + (check (eq :monocle (mode)) "config layout applied at startup") + (check (eq :monocle (mode "right")) "config layout applied on both heads") + (check (= 1 (symbol-value '*default-layout-smoke-loads*)) "config evaluated once") + (check (= 1 (symbol-value '*default-layout-smoke-startups*)) "startup hook executed once") + (lime.x11:backend-use-manual-layout backend) + (lime.x11:reload-backend-configuration backend) + (check (eq :manual (mode)) "file reload preserves current layout") + (check (= 2 (symbol-value '*default-layout-smoke-loads*)) "reload reads the same file") + (check (= 1 (symbol-value '*default-layout-smoke-startups*)) "reload skips startup hooks") + (lime.x11:backend-start-activity backend "after-reload" "After reload") + (check (eq :monocle (mode)) "new drafts after reload follow config") + (check (lime.core:validate-world (world)) "final world invariants") + (format t "~&Live X11 default-layout smoke: ~D checks passed.~%" checks))) + (when backend (lime.x11:stop-backend backend)) + (when client-display (xlib:close-display client-display)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-fixed-size-smoke.lisp b/test/x11-fixed-size-smoke.lisp new file mode 100644 index 0000000..767329a --- /dev/null +++ b/test/x11-fixed-size-smoke.lisp @@ -0,0 +1,143 @@ +;;;; Fixed-size adoption via real MapRequest/PropertyNotify on an owned Xvfb. +;;;; Run with sbcl --non-interactive --load test/x11-fixed-size-smoke.lisp. +;;;; Never connects to the user's DISPLAY or launches Discord itself. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(handler-case + (let ((server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "2000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 1000 :height 622) + (lime.x11:make-x11-head :head-id "right" :x 1000 :y 0 :width 1000 :height 622)))) + (setf clients (xlib:open-default-display display-name) + backend (lime.x11:start-lime :display-name display-name :heads heads + :install-default-keybindings-p nil)) + (setf (lime.x11::x11-backend-window-appearance backend) + (lime.x11:make-window-appearance :border-width 3 :inner-gap 5 :outer-gap 5)) + (let ((root (xlib:screen-root (xlib:display-default-screen clients))) + (fixed (xlib:make-wm-size-hints :min-width 300 :max-width 300 + :min-height 200 :max-height 200))) + (labels ((check (truth label) (assert truth () "Fixed-size: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (id (window) (lime.x11::%backend-client-id backend window)) + (kind (window &optional (head "left")) + (lime.core:placement-kind + (find (id window) (lime.core:presentation-placements (current head)) + :key #'lime.core:placement-client-id :test #'equal))) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0) (display (lime.x11::x11-backend-display backend))) + (lime.x11:run-event-loop + backend :timeout 0.005 + :before-event (lambda (b) + (assert (< (incf turns) 400) () "Fixed-size event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (spawn (&key hints (class "discord") type parent) + (let ((window (xlib:create-window :parent root :x 17 :y 37 + :width 300 :height 200 :background 0))) + (xlib:set-wm-class window class class) + (when hints (setf (xlib:wm-normal-hints window) hints)) + (when type + (xlib:change-property window :_NET_WM_WINDOW_TYPE + (list (xlib:intern-atom clients type)) :ATOM 32)) + (when parent + (xlib:change-property window :WM_TRANSIENT_FOR + (list (xlib:window-id parent)) :WINDOW 32)) + (xlib:map-window window) + (pump) + (check (id window) "MapRequest adopted client") + (check (eq :viewable (xlib:window-map-state window)) "client is visible") + window)) + (destroy (window) (xlib:destroy-window window) (pump)) + (check-full-tile (window) + (check (equal '(0 22 1000 600 0) + (list (xlib:drawable-x window) (xlib:drawable-y window) + (xlib:drawable-width window) (xlib:drawable-height window) + (xlib:drawable-border-width window))) + "sole browser tile retains entire work area without gaps/borders"))) + (lime.x11:backend-select-head backend "left") + (let* ((browser (spawn :class "Browser")) + (popup (spawn :hints fixed))) + (check (eq :tile (kind browser)) "ordinary browser is tiled") + (check (eq :float (kind popup)) "untyped fixed-size startup window floats") + (check (equal '(:normal) (lime.x11::ewmh-client-window-types backend (id popup))) + "float does not depend on an EWMH splash type") + (check-full-tile browser) + (check (equal '(350 222 300 200 3) + (list (xlib:drawable-x popup) (xlib:drawable-y popup) + (xlib:drawable-width popup) (xlib:drawable-height popup) + (xlib:drawable-border-width popup))) + "popup preserves fixed content size, centers in work area, and keeps border") + (check (= (xlib:window-id popup) (xlib:window-id (xlib:input-focus clients))) + "new popup receives real X focus") + ;; The focused Head, not the global root center, owns the popup. + (lime.x11:backend-select-head backend "right") + (let ((other (spawn :hints fixed))) + (check (eq :float (kind other "right")) "popup follows selected Head") + (check (= 1350 (xlib:drawable-x other)) "right popup centers in right work area") + (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend (id other))) + "popup has one lease on right Head") + (check-full-tile browser) + (destroy other)) + (lime.x11:backend-select-head backend "left") + ;; A user can retile it. Subsequent hints must not undo that. + (lime.x11:backend-toggle-client-floating backend (id popup)) + (setf (xlib:wm-normal-hints popup) (xlib:make-wm-size-hints :min-width 100 :min-height 100)) + (pump) + (check (eq :tile (kind popup)) "manual retile survives resizable hints") + (setf (xlib:wm-normal-hints popup) fixed) + (pump) + (check (eq :tile (kind popup)) "later fixed hints do not reclassify existing client") + (destroy popup) + (check-full-tile browser) + ;; Discord's main window uses the same class but only minima. + (let ((main (spawn :hints (xlib:make-wm-size-hints :min-width 800 :min-height 500)))) + (check (eq :tile (kind main)) "resizable Discord main window remains tiled") + (check (< (xlib:drawable-width browser) 1000) "main window participates in master/stack") + (destroy main)) + (check-full-tile browser) + ;; A fixed width alone is not a fixed-size client. + (let ((one-axis (spawn :hints (xlib:make-wm-size-hints :min-width 300 :max-width 300)))) + (check (eq :tile (kind one-axis)) "one fixed axis stays tiled") + (destroy one-axis)) + (setf (lime.x11::x11-backend-configuration backend) + (lime.x11:make-lime-configuration :new-client-focus-p nil)) + (let ((quiet (spawn :hints fixed))) + (check (eq :float (kind quiet)) "no-focus configuration still floats fixed window") + (check (= (xlib:window-id browser) (xlib:window-id (xlib:input-focus clients))) + "configured no-focus-on-new-client respected") + (destroy quiet)) + (setf (lime.x11::x11-backend-configuration backend) + (lime.x11:make-lime-configuration + :rules (list (lime.x11:make-window-rule :resource-class "discord" :float-p nil)))) + (let ((forced (spawn :hints fixed)) + (splash (spawn :type :_NET_WM_WINDOW_TYPE_SPLASH))) + (check (eq :tile (kind forced)) "explicit tiling rule overrides fixed-size default") + (check (eq :float (kind splash)) "EWMH splash policy still wins over ordinary rules") + (lime.x11:backend-select-head backend "right") + (let ((transient (spawn :hints fixed :parent browser))) + (check (eq :float (kind transient)) "transient parent policy still wins") + (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend (id transient))) + "transient follows parent onto left Head") + (destroy transient)) + (destroy forced) (destroy splash)) + (check-full-tile browser) + (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors") + (check (lime.core:validate-world (world)) "final world and leases valid") + (format t "~&Fixed-size smoke: ~D checks passed.~%" checks))))) + (when backend (ignore-errors (lime.x11:stop-backend backend))) + (when clients (ignore-errors (xlib:close-display clients :abort t))) + (uiop:terminate-process server) + (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Fixed-size smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-floating-smoke.lisp b/test/x11-floating-smoke.lisp new file mode 100644 index 0000000..4cc0b17 --- /dev/null +++ b/test/x11-floating-smoke.lisp @@ -0,0 +1,238 @@ +;;;; Floating drag correctness and hot-path regression on an owned Xvfb. +;;;; Never connects to DISPLAY or moves the user's desktop pointer. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(let ((server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (client-display nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (name (format nil ":~D" number))) + (setf client-display (xlib:open-default-display name)) + (let* ((client-root (xlib:screen-root (xlib:display-default-screen client-display))) + (windows (loop repeat 2 collect + (xlib:create-window :parent client-root :x 0 :y 0 + :width 100 :height 100 :background 0)))) + (dolist (window windows) (xlib:map-window window)) + (xlib:display-finish-output client-display) + (setf backend (lime.x11:start-lime + :display-name name :head-discovery :none + :config-file (asdf:system-relative-pathname + "lime" "test/x11-appearance-config.lisp"))) + (let* ((display (lime.x11::x11-backend-display backend)) + (root (lime.x11::x11-backend-root backend)) + (world (lime.x11::x11-backend-world backend)) + (head (first (lime.x11:backend-head-ids backend))) + (client-id (lime.x11::%backend-client-id backend (first windows))) + (wm-window (gethash client-id (lime.x11::x11-backend-client-windows backend))) + ;; Some keymaps also expose a non-modifier Super keysym; + ;; use a physical key assigned to Mod4 for XTest input. + (super (first (nth-value 6 (xlib:modifier-mapping display)))) + (state (xlib:make-state-mask :mod-4 :button-1))) + (labels ((check (truth label) + (assert truth () "Floating smoke: ~A" label) (incf checks)) + (current () (lime.core:current-presentation world head)) + (placement () + (find client-id (lime.core:presentation-placements (current)) + :key #'lime.core:placement-client-id :test #'equal)) + (data () (lime.core:placement-data (placement))) + (pump () + (let ((turns 0)) + (lime.x11:run-event-loop + backend :timeout 0.001 + :before-event + (lambda (backend) + (assert (< (incf turns) 2000) () "Event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p backend) nil)))))) + (motion (x y &optional (window wm-window) (modifiers state)) + (xlib:queue-event display :motion-notify :append-p t + :window window :root root :child nil + :root-x x :root-y y :x 0 :y 0 + :state modifiers :hint-p nil :same-screen-p t :time 0)) + (release (button x y) + (xlib:queue-event display :button-release :append-p t + :window wm-window :root root :child nil + :root-x x :root-y y :x 0 :y 0 + :state state :code button :same-screen-p t :time 0)) + (start (&optional (mode :move)) + (setf (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::make-pointer-drag + :client-id client-id :head-id head :mode mode + :presentation-id (lime.core:presentation-id (current)) + :initial-root-x 300 :initial-root-y 220 + :initial-data (copy-list (data))))) + (check-pixels () + (xlib:display-finish-output display) + (let* ((effect (lime.x11::%floating-client-configure-effect backend (current) client-id)) + (geometry (lime.x11:x11-effect-geometry effect)) + (window (first windows))) + (check (= (xlib:drawable-x window) (lime.core:geometry-x geometry)) "actual x") + (check (= (xlib:drawable-y window) (lime.core:geometry-y geometry)) "actual y") + (check (= (xlib:drawable-width window) (lime.core:geometry-width geometry)) "actual width") + (check (= (xlib:drawable-height window) (lime.core:geometry-height geometry)) "actual height") + (check (= 3 (xlib:drawable-border-width window)) "float retains border")))) + (lime.x11:backend-toggle-client-floating + backend client-id :data '(:x 1/4 :y 1/4 :width 1/2 :height 1/2)) + (lime.x11:backend-focus-client backend client-id) + (pump) + ;; Actual XTest input exercises the passive grab and production routing. + (xlib/xtest:fake-motion-event display 300 220) + (xlib/xtest:fake-key-event display super t) + (xlib/xtest:fake-button-event display 1 t) + (pump) + (check (lime.x11::x11-backend-pointer-drag backend) + (format nil "Super+Button1 starts drag (key ~D, pointer ~S, float ~S, window ~D/~D)" + super (multiple-value-list (xlib:query-pointer root)) (data) + (xlib:drawable-x (first windows)) (xlib:drawable-y (first windows)))) + (xlib/xtest:fake-motion-event display 400 280) + (pump) + (check (= 7/20 (getf (data) :x)) "real drag moves 100 pixels horizontally") + (check (= 7/20 (getf (data) :y)) "real drag moves 60 pixels vertically") + (xlib/xtest:fake-button-event display 1 nil) + (xlib/xtest:fake-key-event display super nil) + (pump) + (check (null (lime.x11::x11-backend-pointer-drag backend)) "real release ends drag") + (check-pixels) + ;; A large motion burst uses a bounded number of geometry updates, + ;; with no desktop reconciliation, refocus, or root property writes. + (lime.x11:backend-set-client-floating-geometry backend client-id :x 1/4 :y 1/4) + (lime.x11:backend-save-view backend "drag-start" "Before dragging") + (lime.x11:backend-activate-view backend "drag-start") + (pump) + (start) + (let ((updates 0) (bars 0) (syncs 0) (focuses 0) + (execute (symbol-function 'lime.x11::%execute-x11-effect)) + (draw (symbol-function 'lime.x11::render-head-bars)) + (sync (symbol-function 'lime.x11::ewmh-sync-client-lists)) + (focus (symbol-function 'lime.x11::icccm-focus-client))) + (unwind-protect + (progn + (setf (symbol-function 'lime.x11::%execute-x11-effect) + (lambda (backend effect) + (incf updates) + (check (and (eq :configure (lime.x11:x11-effect-kind effect)) + (equal client-id (lime.x11:x11-effect-client-id effect))) + "drag only configures its own client") + (funcall execute backend effect)) + (symbol-function 'lime.x11::render-head-bars) + (lambda (backend) (incf bars) (funcall draw backend)) + (symbol-function 'lime.x11::ewmh-sync-client-lists) + (lambda (backend) (incf syncs) (funcall sync backend)) + (symbol-function 'lime.x11::icccm-focus-client) + (lambda (&rest args) (incf focuses) (apply focus args))) + (loop for i from 1 to 600 do (motion (+ 300 (mod i 151)) 280)) + ;; Release has a newer position than the final motion. + (release 1 450 310) + ;; Must not coalesce a later event backward across release. + (motion 900 600) + (pump) + (check (<= 2 updates 4) "600 queued motions collapse into bounded batches") + (check (= 1 bars) "only the clean-to-dirty transition redraws bars") + (check (zerop syncs) "no EWMH list refresh during motion") + (check (zerop focuses) "no focus renegotiation during motion") + (check (= 2/5 (getf (data) :x)) "release's final x wins") + (check (= 2/5 (getf (data) :y)) "release's final y wins") + (check (null (lime.x11::x11-backend-pointer-drag backend)) "queued release ends drag") + (format t "~&600-motion burst: ~D geometry updates, ~D bar redraw, ~D list syncs, ~D refocuses.~%" + updates bars syncs focuses)) + (setf (symbol-function 'lime.x11::%execute-x11-effect) execute + (symbol-function 'lime.x11::render-head-bars) draw + (symbol-function 'lime.x11::ewmh-sync-client-lists) sync + (symbol-function 'lime.x11::icccm-focus-client) focus))) + (check-pixels) + (check (lime.core:validate-world world) "world invariants after burst") + ;; Saved checkpoints retain their original geometry until updated. + (lime.x11:backend-activate-view backend "drag-start") + (check (= 1/4 (getf (data) :x)) "checkpoint geometry was not mutated") + (pump) + (start) + (let ((revision (lime.core:world-revision world))) + (lime.x11::%handle-motion-notify backend 300 220 state) + (check (= revision (lime.core:world-revision world)) "stationary motion is a no-op") + (check (not (lime.core:presentation-dirty-p (current))) "stationary click stays clean")) + ;; Resize shares the light path and still honors client increments. + (setf (xlib:wm-normal-hints (first windows)) + (xlib:make-wm-size-hints :min-width 80 :min-height 60 + :width-inc 8 :height-inc 10)) + (xlib:display-finish-output client-display) + (pump) + (start :resize) + (motion 350 250) + (release 1 355 255) + (pump) + (check (lime.x11::x11-backend-pointer-drag backend) "unrelated release does not end resize") + (release 3 360 260) + (pump) + (check (= 14/25 (getf (data) :width)) "resize ends at release width") + (check (= 17/30 (getf (data) :height)) "resize ends at release height") + (check-pixels) + (check (zerop (mod (xlib:drawable-width (first windows)) 8)) "resize respects width increments") + (check (zerop (mod (xlib:drawable-height (first windows)) 10)) "resize respects height increments") + ;; Report, rather than assert, wall-clock timing: the stable + ;; regression above asserts protocol work, not machine speed. + (lime.x11:backend-set-client-floating-geometry + backend client-id :x 1/4 :y 1/4 :width 1/2 :height 1/2) + (flet ((measure (function) + (xlib:display-finish-output display) + (let ((start (get-internal-real-time))) + (dotimes (i 120) (funcall function (/ (+ 200 i) 1000))) + (xlib:display-finish-output display) + (/ (- (get-internal-real-time) start) + (float internal-time-units-per-second))))) + (let* ((full (measure + (lambda (x) + (lime.core:set-client-floating-geometry + world (lime.core:presentation-id (current)) client-id :x x) + (lime.x11:apply-active-presentation backend)))) + (delta (measure + (lambda (x) + (lime.x11:backend-set-client-floating-geometry backend client-id :x x))))) + (format t "~&120 uncoalesced geometry edits: full desktop ~,3Fs; geometry-only ~,3Fs.~%" + full delta))) + (pump) + ;; Commands/lifecycle events are coalescing boundaries, not discarded. + (start) + (motion 310 230) + (xlib:queue-event display :key-press :append-p t :window root :root root + :child nil :root-x 0 :root-y 0 :x 0 :y 0 :state 0 + :code super :same-screen-p t :time 0) + (motion 320 240) + (multiple-value-bind (x y) + (lime.x11::%coalesce-drag-motion backend wm-window 300 220 state) + (check (and (= x 310) (= y 230)) "coalescing stops before key press")) + (check (eq :key-press + (xlib:event-case (display :timeout 0) + (:key-press () :key-press) (otherwise () :unexpected))) + "key press remains in queue") + (pump) + (start) + (let ((old (current))) + (lime.x11:backend-start-activity backend "other" "Other") + (let ((revision (lime.core:world-revision world))) + (lime.x11::%handle-motion-notify backend 500 400 state) + (check (= revision (lime.core:world-revision world)) "switching draft invalidates gesture") + (check (null (lime.x11::x11-backend-pointer-drag backend)) "stale draft drag cancelled")) + (lime.x11:backend-activate-activity backend (lime.core:presentation-activity-id old))) + (pump) + (start) + (lime.x11:backend-toggle-client-floating backend client-id) + (lime.x11::%handle-motion-notify backend 500 400 state) + (check (null (lime.x11::x11-backend-pointer-drag backend)) "unfloating cancels gesture") + (lime.x11:backend-toggle-client-floating backend client-id) + (start) + (xlib:destroy-window (first windows)) + (xlib:display-finish-output client-display) + (pump) + (check (null (lime.x11::x11-backend-pointer-drag backend)) "destroyed client cancels gesture") + (check (lime.core:validate-world world) "world invariants after destruction") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no swallowed drag errors") + (format t "~&Live X11 floating: ~D checks passed.~%" checks))))) + (when backend (lime.x11:stop-backend backend)) + (when client-display (xlib:close-display client-display)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-font-smoke.lisp b/test/x11-font-smoke.lisp new file mode 100644 index 0000000..f5d920e --- /dev/null +++ b/test/x11-font-smoke.lisp @@ -0,0 +1,163 @@ +;;;; Opt-in isolated-X font/overlay regression, including live reload/rollback. +;;;; Requires Xvfb, Pango/Cairo, and fonts covering Japanese and color emoji. +;;;; Optional: bind CL-USER::*FONT-SMOKE-IMAGE-DIRECTORY* before loading to save +;;;; bar.png and palette.png for inspection. Never uses the current DISPLAY. +;;;; *FONT-SMOKE-FONT-OPTIONS* optionally supplies MAKE-UI-FONT-STYLE keywords. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(defvar *font-smoke-image-directory* nil) +(defvar *font-smoke-font-options* nil) + +(dolist (depth '(24 16)) + (let ((server (uiop:launch-program + (list "Xvfb" "-displayfd" "1" "-screen" "0" + (format nil "1000x622x~D" depth) "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (configuration (lime.x11:make-lime-configuration + :default-keybindings-p nil + :bar-style (lime.x11:make-head-bar-style + :foreground "#dbc9a6" :focused-foreground "#dbc9a6" + :accent-color "#ffb054" :menu-label-color "#dbc9a6" + :logo-color "#768565") + :font (apply #'lime.x11:make-ui-font-style *font-smoke-font-options*) + :bar-height 24 :bar-height-supplied-p t))) + (setf backend (lime.x11:start-lime + :display-name (format nil ":~D" number) :head-discovery :none)) + (lime.x11:apply-lime-configuration backend configuration) + (let* ((display (lime.x11::x11-backend-display backend)) + (head (first (lime.x11:backend-head-ids backend))) + (bar (gethash head (lime.x11::x11-backend-head-bars backend))) + (client (xlib:create-window :parent (lime.x11::x11-backend-root backend) + :x 0 :y 0 :width 100 :height 100)) + (labels '("café — 日本語 🎮" "👩‍💻 Coding and debugging" + "مرحبا بالعالم" "é — combining accents")) + (session (lime.ui:make-ui-session + (loop for label in labels for id from 0 collect + (lime.ui:make-ui-candidate :id id :label label :detail "Unicode sample"))))) + (labels ((check (truth label) + (assert truth () "Font smoke (~D-bit): ~A" depth label) + (incf checks)) + (check-frame (canvas window) + (xlib:display-finish-output display) + (check (equalp (lime.x11::ui-canvas-pixels canvas) + (xlib:image-z-pixarray + (xlib:get-image window :x 0 :y 0 + :width (lime.x11::ui-canvas-width canvas) + :height (lime.x11::ui-canvas-height canvas) + :format :z-pixmap))) + "painted frame survives the X11 pixel upload")) + (snapshot (canvas name) + (when (and (= depth 24) *font-smoke-image-directory*) + (check (zerop (lime.x11::%cairo-write-png + (lime.x11::ui-canvas-surface canvas) + (namestring (merge-pathnames name *font-smoke-image-directory*)))) + "PNG snapshot")))) + (xlib:change-property client :_NET_WM_NAME + (babel:string-to-octets (first labels) :encoding :utf-8) + :UTF8_STRING 8) + (lime.x11:manage-window backend client) + (lime.x11:backend-set-head-bar-status-providers + backend (list (lambda (&rest ignored) + (declare (ignore ignored)) + (list (lime.x11:format-music-status '(:state :playing :title "スパイダー") + :playing-icon "▶" :icon-foreground "#76929f") + (lime.x11:format-volume-status '(:volume 25) :icon "♪" + :icon-foreground "#76929f"))))) + (check-frame (lime.x11::x11-head-bar-canvas bar) (lime.x11::x11-head-bar-window bar)) + (let ((pixels (lime.x11::ui-canvas-pixels (lime.x11::x11-head-bar-canvas bar)))) + (check (loop for y below 24 always + (loop for x below 10 always + (= (aref pixels y x) (aref pixels 0 0) + (aref pixels y (- 999 x))))) + "both outer text margins remain clear")) + ;; Inspect native RGB pixels: the logo is green, not the cream + ;; used by neighboring labels (before depth-specific upload). + (let* ((canvas (lime.x11::x11-head-bar-canvas bar)) + (data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas))) + (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas))) + (right (lime.x11::x11-head-bar-hit-region-right + (first (lime.x11::x11-head-bar-hit-regions bar))))) + (check (loop for y below 24 thereis + (loop for x from 10 below right + for pixel = (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4))) + thereis (> (ldb (byte 8 8) pixel) + (max (ldb (byte 8 16) pixel) (ldb (byte 8 0) pixel))))) + "Lime logo uses its independent green foreground")) + (snapshot (lime.x11::x11-head-bar-canvas bar) "bar.png") + (lime.x11::%open-ui-session backend session) + (let* ((overlay (lime.x11::x11-backend-ui-overlay backend)) + (old-bar-font (lime.x11::x11-head-bar-font bar)) + (old-font (lime.x11::x11-ui-overlay-font overlay)) + (old-canvas (lime.x11::x11-ui-overlay-canvas overlay)) + (old-height (lime.x11::x11-ui-overlay-height overlay)) + (large (lime.x11::copy-lime-configuration configuration))) + (dolist (text labels) + (check (zerop (lime.x11::text-metrics-unknown-glyphs + (lime.x11::%text-metrics old-font text))) + (format nil "installed fonts cover ~S" text))) + (check-frame old-canvas (lime.x11::x11-ui-overlay-window overlay)) + (snapshot old-canvas "palette.png") + (lime.x11::%render-command-palette backend) + (check (eq old-canvas (lime.x11::x11-ui-overlay-canvas overlay)) "reuse same-size canvas") + (check (eq old-font (lime.x11::x11-ui-overlay-font overlay)) "reuse unchanged font") + (setf (lime.x11:lime-configuration-font large) + (lime.x11:make-ui-font-style :family "sans-serif, Noto Color Emoji" :size 22 :weight :bold) + (lime.x11:lime-configuration-bar-height large) 36) + (setf (lime.x11:lime-configuration-bar-style large) + (lime.x11:make-head-bar-style :padding-x 16)) + (lime.x11:apply-lime-configuration backend large) + (check (= (+ 16 (lime.x11::%text-width (lime.x11::x11-head-bar-font bar) "Lime")) + (lime.x11::x11-head-bar-hit-region-right + (first (lime.x11::x11-head-bar-hit-regions bar)))) + "padding reload also updates click geometry") + (check (eq session (lime.x11::x11-backend-ui-session backend)) "reload preserves open session") + (check (eq overlay (lime.x11::x11-backend-ui-overlay backend)) "reload preserves overlay window") + (check (> (lime.x11::x11-ui-overlay-height overlay) old-height) "font increases measured row height") + (check (= 36 (xlib:drawable-y (lime.x11::x11-ui-overlay-window overlay))) "overlay follows new bar height") + (check (null (lime.x11::ui-text-font-layout old-font)) "reload frees old palette font") + (check (null (lime.x11::ui-text-font-layout old-bar-font)) "reload frees old bar font") + (check (null (lime.x11::ui-canvas-surface old-canvas)) "resize frees old canvas") + (check (= 22 (lime.x11:ui-font-style-size + (lime.x11::ui-text-font-style (lime.x11::x11-ui-overlay-font overlay)))) + "palette uses configured pixel size") + (check-frame (lime.x11::x11-ui-overlay-canvas overlay) (lime.x11::x11-ui-overlay-window overlay)) + (let ((bad (lime.x11::copy-lime-configuration large)) + (failed nil) (failed-font nil)) + (setf (lime.x11:lime-configuration-font bad) (lime.x11:make-ui-font-style :size 10) + (lime.x11:lime-configuration-startup-hooks bad) + (list (lambda (ignored) + (declare (ignore ignored)) + (setf failed-font (lime.x11::x11-ui-overlay-font overlay)) + (error "Deliberate font rollback")))) + (handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t) + (error () (setf failed t))) + (check (and failed failed-font) "installation reaches deliberate rollback") + (check (eq large (lime.x11:x11-backend-configuration backend)) "previous config restored") + (check (null (lime.x11::ui-text-font-layout failed-font)) "rollback frees failed font") + (check (= 22 (lime.x11:ui-font-style-size + (lime.x11::ui-text-font-style (lime.x11::x11-head-bar-font bar)))) + "rollback restores bar font") + (check (= 22 (lime.x11:ui-font-style-size + (lime.x11::ui-text-font-style (lime.x11::x11-ui-overlay-font overlay)))) + "rollback restores overlay font") + (check-frame (lime.x11::x11-ui-overlay-canvas overlay) (lime.x11::x11-ui-overlay-window overlay))) + ;; Closing and reopening frees all transient native resources. + (lime.x11:backend-close-command-palette backend) + (check (null (lime.x11::ui-text-font-layout (lime.x11::x11-ui-overlay-font overlay))) + "close frees palette layout") + (check (null (lime.x11::ui-canvas-surface (lime.x11::x11-ui-overlay-canvas overlay))) + "close frees palette canvas") + (lime.x11::%open-ui-session backend session) + (check (not (eq overlay (lime.x11::x11-backend-ui-overlay backend))) "reopen builds a new overlay")) + (lime.x11:stop-backend backend) + (setf backend nil) + (check (null (lime.x11::ui-text-font-layout (lime.x11::x11-head-bar-font bar))) "shutdown frees bar font") + (check (null (lime.x11::ui-canvas-surface (lime.x11::x11-head-bar-canvas bar))) "shutdown frees bar canvas") + (format t "~&Live X11 fonts (~D-bit): ~D checks passed.~%" depth checks)))) + (when backend (lime.x11:stop-backend backend)) + (uiop:terminate-process server) + (uiop:wait-process server)))) diff --git a/test/x11-head-send-smoke.lisp b/test/x11-head-send-smoke.lisp new file mode 100644 index 0000000..b5104d5 --- /dev/null +++ b/test/x11-head-send-smoke.lisp @@ -0,0 +1,175 @@ +;;;; Physical key grabs and clickable confirmation on our own Xvfb only. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(lime.config:defconfiguration head-send-smoke-config + (:command send-window :label "Send window" + :action (lambda (backend) (lime.x11:backend-send-focused-client-relatively backend :next))) + (:bind #\e send-window :modifiers '(:mod-4 :shift))) + +(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 622) + (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 622)))) + (setf backend (lime.x11:start-lime :display-name display-name :heads heads :install-default-keybindings-p nil) + clients (xlib:open-default-display display-name)) + (lime.x11:apply-lime-configuration backend head-send-smoke-config) + (labels ((check (truth label) (assert truth () "Head send: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (session () (lime.x11::x11-backend-ui-session backend)) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0) (display (lime.x11::x11-backend-display backend))) + (lime.x11:run-event-loop backend :timeout 0.005 + :before-event (lambda (b) + (assert (< (incf turns) 500) () "Event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (tap (keysym &optional modified-p) + (let* ((display (lime.x11::x11-backend-display backend)) + (super (first (nth-value 6 (xlib:modifier-mapping display)))) + (shift (first (nth-value 0 (xlib:modifier-mapping display)))) + (key (xlib:keysym->keycodes display keysym))) + (assert key) + (when modified-p + (xlib/xtest:fake-key-event clients super t) + (xlib/xtest:fake-key-event clients shift t)) + (xlib/xtest:fake-key-event clients key t) + (xlib/xtest:fake-key-event clients key nil) + (when modified-p + (xlib/xtest:fake-key-event clients shift nil) + (xlib/xtest:fake-key-event clients super nil)) + (pump))) + (spawn () + (let ((window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen clients)) + :x 30 :y 30 :width 120 :height 120))) + (xlib:map-window window) (pump) + (values window (lime.x11::%backend-client-id backend window)))) + (lease-head (id) (lime.x11::ewmh-active-head-id-for-client backend id)) + (choose (id) + (let ((candidate (find id (lime.ui:ui-session-candidates (session)) + :key #'lime.ui:ui-candidate-id :test #'equal))) + (check candidate "choice present") + (lime.x11::%perform-ui-action backend (list :candidate candidate)) + (pump)))) + (lime.x11:backend-start-activity backend "work" "Work") + (lime.x11:backend-start-activity backend "chill" "Chill" :head-id "right") + (lime.x11:backend-select-head backend "left") + (multiple-value-bind (a aid) (spawn) + (multiple-value-bind (b bid) (spawn) + (lime.x11:backend-save-view backend "code" "Code") + (lime.x11:backend-select-head backend "right") + (multiple-value-bind (c cid) (spawn) + (lime.x11:backend-use-monocle-layout backend) + (lime.x11:backend-save-view backend "chat" "Chat") + (lime.x11:backend-select-head backend "left") + (pump) + (let ((before (lime.persistence:snapshot-world (world)))) + (tap (char-code #\e) t) + (check (session) "Super-Shift-e opens confirmation") + (check (equal "left" (lime.x11::x11-ui-overlay-head-id (lime.x11::x11-backend-ui-overlay backend))) + "confirmation is on source Head") + (check (< (lime.x11::x11-ui-overlay-height (lime.x11::x11-backend-ui-overlay backend)) 220) + "two-choice dropdown stays compact") + (check (eq :cancel (lime.ui:ui-candidate-id (lime.ui:ui-session-selected-candidate (session)))) + "default is Cancel") + (check (search "saved views" (lime.ui:ui-candidate-detail + (lime.ui:ui-session-selected-candidate (session)))) "warning visible on default choice") + (check (equalp before (lime.persistence:snapshot-world (world))) "opening is read-only") + (tap #xFF0D) + (check (not (session)) "Enter cancels by default") + (check (equalp before (lime.persistence:snapshot-world (world))) "cancel leaves desk untouched") + (check (equal "left" (lime.x11:x11-backend-focused-head-id backend)) "cancel keeps source Head selected") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "cancel preserves real focus")) + ;; Configured command search returns a transition into the + ;; existing overlay, rather than opening then closing itself. + (lime.x11:backend-open-command-palette backend) + (tap (char-code #\Space)) + (choose '(:configured-command send-window)) + (check (session) "configured search action keeps confirmation open") + (tap #xFF1B) + ;; The which-key path shares the same action and click regions. + (lime.x11:backend-open-command-palette backend) + (tap (char-code #\h)) (tap (char-code #\s)) + (check (session) "h s opens confirmation") + (let* ((overlay (lime.x11::x11-backend-ui-overlay backend)) + (candidate (second (lime.ui:ui-session-candidates (session)))) + (region (find (list :candidate candidate) (lime.x11::x11-ui-overlay-hit-regions overlay) + :key #'lime.x11::ui-hit-region-action :test #'equal))) + (check region "Move is clickable") + (xlib/xtest:fake-motion-event + clients (+ (xlib:drawable-x (lime.x11::x11-ui-overlay-window overlay)) + (lime.x11::ui-hit-region-x region) 10) + (+ (xlib:drawable-y (lime.x11::x11-ui-overlay-window overlay)) + (lime.x11::ui-hit-region-y region) 5)) + (pump) + (xlib/xtest:fake-button-event clients 1 t) + (xlib/xtest:fake-button-event clients 1 nil) + (pump)) + (check (not (session)) "click confirms and closes dropdown") + (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) bid))) "home changed") + (check (equal "right" (lease-head bid)) "one destination lease") + (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "source Activity unchanged") + (check (equal "chill" (lime.core:presentation-activity-id (current "right"))) "destination Activity unchanged") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "keyboard Head follows confirmed move") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "sent client gets actual X focus") + (check (equal aid (lime.core:presentation-focus-client-id (current "left"))) "source remembers survivor") + (check (eq :viewable (xlib:window-map-state b)) "sent window visible in monocle") + (check (eq :unmapped (xlib:window-map-state c)) "previous monocle client stays in cycle but is not shown") + (check (>= (xlib:drawable-x b) 600) "real window moved right") + (check (equal (list aid) (mapcar #'lime.core:placement-client-id + (lime.core:view-placements (lime.core:find-view (world) "code")))) "old checkpoint pruned") + (check (equal (list cid) (mapcar #'lime.core:placement-client-id + (lime.core:view-placements (lime.core:find-view (world) "chat")))) "destination checkpoint not overwritten") + ;; Same Activity: immediate transfer, no confirmation. + (lime.x11:backend-extend-activity-to-head backend "chill" "left") + (lime.x11:backend-select-head backend "right") + (tap (char-code #\e) t) + (check (not (session)) "same Activity sends immediately") + (check (equal "left" (lease-head bid)) "same-Activity transfer moves lease") + (check (equal "left" (lime.x11:x11-backend-focused-head-id backend)) "same-Activity focus follows") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "same-Activity real focus follows") + ;; Repeat the binding directly: no separate Head focus command. + (tap (char-code #\e) t) + (check (equal "right" (lease-head bid)) "repeated shortcut sends same client back") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "repeated shortcut follows back") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "repeated shortcut keeps real focus") + (tap (char-code #\e) t) + (check (equal "left" (lease-head bid)) "third shortcut still targets same client") + ;; Shared float crosses back to Work without rehoming. + (lime.x11:backend-switch-to-activity backend "work" :head-id "right") + (lime.x11:backend-select-head backend "left") + (lime.x11:backend-set-client-shared backend bid t) + (lime.x11:backend-toggle-focused-client-floating backend) + (let ((data (copy-tree (lime.core:placement-data + (find bid (lime.core:presentation-placements (current "left")) + :key #'lime.core:placement-client-id :test #'equal))))) + (tap (char-code #\e) t) + (check (not (session)) "shared cross-Activity send is immediate") + (check (equal "right" (lease-head bid)) "shared lease moved") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "shared floating move follows") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "shared float gets real focus") + (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) bid))) "shared home unchanged") + (check (equal data (lime.core:placement-data + (find bid (lime.core:presentation-placements (current "right")) + :key #'lime.core:placement-client-id :test #'equal))) + "normalized floating geometry retained")) + (multiple-value-bind (d did) (spawn) + (check (equal "right" (lease-head did)) "new window routes to followed Head") + (check (equal "work" (lime.core:client-activity-id (lime.core:find-client (world) did))) + "new window belongs to followed Activity") + (check (= (xlib:window-id d) (xlib:window-id (xlib:input-focus clients))) "new window focuses on destination")) + (check (lime.core:validate-world (world)) "world valid after all moves") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors") + (format t "~&Live X11 Head-send smoke: ~D checks passed.~%" checks)))))) + (when backend (lime.x11:stop-backend backend)) + (when clients (xlib:close-display clients)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-launcher-smoke.lisp b/test/x11-launcher-smoke.lisp new file mode 100644 index 0000000..f1a6515 --- /dev/null +++ b/test/x11-launcher-smoke.lisp @@ -0,0 +1,124 @@ +;;;; Burst typing and grab cleanup on an owned Xvfb, never the live DISPLAY. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(handler-case +(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0) + (original-launch (symbol-function 'lime.x11:backend-launch-program)) + (original-scan (symbol-function 'lime.x11::%scan-path-program-names)) + (original-overlay (symbol-function 'lime.x11::%make-ui-overlay)) + (lime.x11::*path-program-cache* nil)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (launched nil) (queries nil) (scans 0) (typed nil) (ordinary 0)) + (setf backend (lime.x11:start-lime :display-name display-name :head-discovery :none + :install-default-keybindings-p nil) + clients (xlib:open-default-display display-name)) + (let* ((display (lime.x11::x11-backend-display backend)) + (super (first (nth-value 6 (xlib:modifier-mapping display)))) + (window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen clients)) + :x 20 :y 20 :width 100 :height 100 :event-mask '(:key-press)))) + (labels ((check (truth label) (assert truth () "Launcher: ~A" label) (incf checks)) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0)) + (lime.x11:run-event-loop + backend :timeout 0.005 + :before-event (lambda (b) + (assert (< (incf turns) 500) () "Event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (tap (keysym) + (let ((code (xlib:keysym->keycodes display keysym))) + (assert code) + (xlib/xtest:fake-key-event clients code t) + (xlib/xtest:fake-key-event clients code nil))) + (shortcut (char) + (xlib/xtest:fake-key-event clients super t) + (tap (char-code char)) + (xlib/xtest:fake-key-event clients super nil)) + (text-burst (text) + (loop for char across text do (tap (char-code char)))) + (read-client-keys () + (xlib:display-finish-output clients) + (loop while (xlib:event-listen clients) + do (xlib:event-case (clients :timeout 0) + (:key-press (code state) + (let ((char (xlib:keysym->character clients (xlib:keycode->keysym clients code 0) state))) + (when (and (characterp char) (graphic-char-p char)) (push char typed))) t) + (otherwise () t))))) + (xlib:map-window window) (pump) + (check (= (xlib:window-id window) (xlib:window-id (xlib:input-focus clients))) "application has real focus") + ;; Measure actual cold/warm opening with the real PATH catalog. + (dotimes (i 3) + (let ((start (get-internal-real-time))) + (lime.x11:backend-open-run-prompt backend) + (xlib:display-finish-output display) + (format t "~&Launcher ~A open: ~,2F ms~%" (if (zerop i) "cold" "warm") + (* 1000.0 (/ (- (get-internal-real-time) start) internal-time-units-per-second)))) + (lime.x11:backend-close-command-palette backend) (pump)) + ;; Stub only process creation and catalog discovery, not X grabs, + ;; filtering, menu creation, event dispatch, or key delivery. + (setf lime.x11::*path-program-cache* nil + (symbol-function 'lime.x11::%scan-path-program-names) + (lambda () (incf scans) (sleep 0.05) '("emoji-menu" "st")) + (symbol-function 'lime.x11:backend-launch-program) + (lambda (b argv) + (push argv launched) + (push (lime.ui:ui-session-query (lime.x11::x11-backend-ui-session b)) queries))) + (lime.x11:bind-key backend #\p '(:mod-4) #'lime.x11:backend-open-run-prompt) + (xlib:display-finish-output display) + (dotimes (i 3) + ;; No event pumping between the trigger and the following keys. + (shortcut #\p) (text-burst "emo") (tap #xFF0D) + (pump) (read-client-keys) + (check (not (lime.x11:backend-command-palette-open-p backend)) "burst Enter launches and closes") + (check (= (1+ i) (length launched)) "exactly one program launched per burst") + (check (equal '("emoji-menu") (first launched)) "correct executable selected") + (check (equal "emo" (first queries)) "first letter and complete query retained") + (check (null typed) "no characters leaked into old application")) + (check (= 1 scans) "subsequent opens reuse executable catalog") + ;; Prefix menus use the same safe handoff. + (lime.x11:bind-key backend #\y '(:mod-4) #'lime.x11:backend-open-command-palette) + (xlib:display-finish-output display) + (shortcut #\y) (tap (char-code #\w)) (pump) (read-client-keys) + (check (equal "Lime › w Windows" (lime.x11::%ui-menu-heading (lime.x11::x11-backend-ui-session backend))) + "fast which-key prefix retained") + (check (null typed) "prefix did not reach application") + (tap #xFF1B) (pump) + ;; Ordinary commands and failures must not leave input frozen. + (lime.x11:bind-key backend #\n '(:mod-4) (lambda (b) (declare (ignore b)) (incf ordinary))) + (lime.x11:bind-key backend #\f '(:mod-4) (lambda (b) (declare (ignore b)) (error "expected test failure"))) + (xlib:display-finish-output display) + (shortcut #\n) (text-burst "a") (pump) (read-client-keys) + (check (= 1 ordinary) "ordinary shortcut ran") + (check (equal '(#\a) typed) "ordinary command thawed keyboard") + (setf typed nil) + (shortcut #\f) (text-burst "b") (pump) (read-client-keys) + (check (lime.x11:backend-last-command-error backend) "handler error contained") + (check (equal '(#\b) typed) "failed command thawed keyboard") + (setf typed nil (symbol-function 'lime.x11::%make-ui-overlay) + (lambda (&rest args) (declare (ignore args)) (error "expected overlay failure"))) + (shortcut #\p) (text-burst "c") (pump) (read-client-keys) + (check (not (lime.x11:backend-command-palette-open-p backend)) "failed opening leaves no session") + (check (equal '(#\c) typed) "failed opening thawed keyboard") + (setf (symbol-function 'lime.x11::%make-ui-overlay) original-overlay) + ;; Release/ungrab remains correct after all success/error paths. + (check (eq :success (xlib:grab-keyboard window)) "another client can grab after cleanup") + (xlib:ungrab-keyboard clients) (xlib:display-finish-output clients) + (format t "~&Live X11 launcher smoke: ~D checks passed.~%" checks)))) + (setf (symbol-function 'lime.x11:backend-launch-program) original-launch + (symbol-function 'lime.x11::%scan-path-program-names) original-scan + (symbol-function 'lime.x11::%make-ui-overlay) original-overlay) + (when backend (lime.x11:stop-backend backend)) + (when clients (xlib:close-display clients)) + (uiop:terminate-process server) + (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Launcher smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-membership-smoke.lisp b/test/x11-membership-smoke.lisp new file mode 100644 index 0000000..b52ed4d --- /dev/null +++ b/test/x11-membership-smoke.lisp @@ -0,0 +1,196 @@ +;;;; Owned Xvfb only: real windows, menu actions, leases, and session restore. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(handler-case + (let* ((directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) + (uiop:run-program '("mktemp" "-d" "/tmp/lime-membership-XXXXXX") :output :string)))) + (path (merge-pathnames "session.sexp" directory)) + (server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x600x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 600) + (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 600)))) + (setf clients (xlib:open-default-display display-name)) + (let* ((root (xlib:screen-root (xlib:display-default-screen clients))) + (a (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)) + (b (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100)) + (aid nil) (bid nil)) + (labels ((check (truth label) (assert truth () "Membership: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (session () (lime.x11::x11-backend-ui-session backend)) + (start () (setf backend (lime.x11:start-lime :display-name display-name :heads heads + :install-default-keybindings-p nil :session-file path))) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0) (display (lime.x11::x11-backend-display backend))) + (lime.x11:run-event-loop + backend :timeout 0.005 + :before-event (lambda (b) + (assert (< (incf turns) 400) () "Membership event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (key (key) (lime.x11::%perform-ui-action backend (list :key key)) (pump)) + (choose (id) + (let ((candidate (find id (lime.ui:ui-session-candidates (session)) + :key #'lime.ui:ui-candidate-id :test #'equal))) + (check candidate (format nil "candidate ~S" id)) + (lime.x11::%perform-ui-action backend (list :candidate candidate))) + (pump)) + (adopt (window) + (xlib:display-finish-output clients) + (prog1 (lime.x11:manage-window backend + (xlib::lookup-window (lime.x11::x11-backend-display backend) + (xlib:window-id window))) + (pump)))) + (start) + (lime.x11:backend-start-activity backend "work" "Work") + (lime.x11:backend-start-activity backend "chill" "Chill" :head-id "right") + (lime.x11:backend-select-head backend "left") + (setf aid (adopt a) bid (adopt b)) + (lime.x11:backend-save-view backend "code" "Code") + (check (eq :viewable (xlib:window-map-state a)) "A initially shown") + (check (eq :viewable (xlib:window-map-state b)) "B initially shown") + (lime.x11:backend-open-command-palette backend) + (key #\w) (key #\m) + (check (eq :search (lime.ui:ui-session-mode (session))) "w m opens destination picker") + (choose (list :move-client-to-activity bid "chill")) + (check (not (session)) "move closes menu") + (check (eq :viewable (xlib:window-map-state b)) "portable destination receives window without closing it") + (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "unmap did not withdraw client") + (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "move stays in source Activity") + (check (equal (list bid) (lime.core:presentation-client-ids (current "right"))) "window joins actual portable arrangement") + (check (equal aid (lime.core:presentation-focus-client-id (current "left"))) "source focuses surviving client") + (check (equal (list aid) (mapcar #'lime.core:placement-client-id + (lime.core:view-placements (lime.core:find-view (world) "code")))) "checkpoint pruned") + (lime.x11:backend-activate-activity backend "chill" :head-id "left") + (pump) + (check (eq :viewable (xlib:window-map-state b)) "destination draft shows moved window") + (check (= (xlib:window-id b) (xlib:window-id (xlib:input-focus clients))) "moved window receives real focus") + (lime.x11:backend-activate-activity backend "work" :head-id "left") + (pump) + (lime.x11:backend-open-command-palette backend) + (key #\w) (key #\s) + (check (not (session)) "share action closes menu") + (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "shared flag enabled") + (check (< (xlib:drawable-x a) 600) "sharing alone does not move window") + (lime.x11:backend-select-head backend "right") + (lime.x11:backend-open-hidden-client-picker backend) + (let ((before (lime.persistence:snapshot-world (world)))) + (choose (list :show-hidden-client aid)) + (check (equalp before (lime.persistence:snapshot-world (world))) "collision prompt changes no model state")) + (choose (list :take-hidden-client aid)) + (check (not (session)) "explicit take closes menu") + (check (>= (xlib:drawable-x a) 600) "same real window now on right Head") + (check (= (xlib:window-id a) (xlib:window-id (xlib:input-focus clients))) "borrowed window focused") + (check (equal "work" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "home unchanged") + (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "one lease on right") + (check (lime.core:validate-world (world)) "borrowed desk valid") + (lime.x11:backend-hide-client backend bid :head-id "right") + (lime.x11:backend-save-view backend "music" "Music") + ;; Persist shared guest plus moved private client, then reconnect + ;; to both existing XIDs, including the currently hidden one. + (lime.x11:backend-save-session backend) + (lime.x11:stop-backend backend) + (setf backend nil) + (start) (pump) + (check (= 2 (getf (getf (lime.x11:backend-session-status backend) :restore) :matched)) "restart matches both clients") + (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "sharing restored") + (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "borrowed lease restored") + (check (eq :unmapped (xlib:window-map-state b)) "moved private window remains parked") + (check (>= (xlib:drawable-x a) 600) "borrowed real placement restored") + ;; Left still has an unavailable slot, not an omitted placement; + ;; the same Super-i workflow must be able to take it back. + (lime.x11:backend-select-head backend "left") + (lime.x11:backend-open-hidden-client-picker backend) + (choose (list :show-hidden-client aid)) + (choose (list :take-hidden-client aid)) + (check (< (xlib:drawable-x a) 600) "shared slot summoned back") + (lime.x11:backend-show-client-taking backend aid :head-id "right") + (pump) + (let ((before (lime.persistence:snapshot-world (world))) + (lease (lime.core:lease-for-client (world) aid)) + (target (current "right")) + (geometry (list (xlib:drawable-x a) (xlib:drawable-y a) + (xlib:drawable-width a) (xlib:drawable-height a)))) + (lime.x11:backend-open-command-palette backend) + (key #\w) (key #\s) + (check (lime.core:client-shared-p (lime.core:find-client (world) aid)) "private action waits for confirmation") + (check (find "Make private to Chill" (lime.ui:ui-session-candidates (session)) + :key #'lime.ui:ui-candidate-label :test #'equal) "confirmation names current Activity") + (key :return) + (check (not (session)) "private confirmation defaults to Cancel") + (check (equalp before (lime.persistence:snapshot-world (world))) "Cancel leaves world untouched") + (lime.x11:backend-open-command-palette backend) + (key #\w) (key #\s) + (choose (list :make-client-private aid)) + (check (eq :viewable (xlib:window-map-state a)) "private window stays mapped") + (check (equal geometry (list (xlib:drawable-x a) (xlib:drawable-y a) + (xlib:drawable-width a) (xlib:drawable-height a))) "geometry unchanged") + (check (= (xlib:window-id a) (xlib:window-id (xlib:input-focus clients))) "real focus unchanged") + (check (eq lease (lime.core:lease-for-client (world) aid)) "same lease object retained") + (check (eq target (current "right")) "same arrangement retained")) + (check (not (lime.core:client-shared-p (lime.core:find-client (world) aid))) "sharing revoked") + (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "current Activity becomes home") + (check (null (lime.core:view-placements (lime.core:find-view (world) "code"))) "old home checkpoint cleaned") + (check (equal (list aid) (mapcar #'lime.core:placement-client-id + (lime.core:view-placements (lime.core:find-view (world) "music")))) "current Activity checkpoint retained") + (check (handler-case (progn (lime.x11:backend-show-client backend aid :head-id "left") nil) + (lime.core:invalid-transition () t)) "old home cannot reclaim private client") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors") + (check (lime.core:validate-world (world)) "final world valid") + ;; Deletion uses a picker and explicit confirmation, never an + ;; application close. Exercise actual key/menu dispatch and X. + (lime.x11:backend-start-activity backend "old" "Old task" :head-id "left") + (lime.x11:backend-save-view backend "old/checkpoint" "Checkpoint" :head-id "left") + (lime.x11:backend-activate-activity backend "work" :head-id "left") + (pump) + (let ((snapshot (lime.persistence:snapshot-world (world)))) + (lime.x11:backend-open-command-palette backend) + (key #\a) (key #\d) + (check (eq :search (lime.ui:ui-session-mode (session))) "a d opens deletion picker") + (choose '(:delete-activity "old")) + (check (equalp snapshot (lime.persistence:snapshot-world (world))) "deletion prompt does not mutate") + (key :return) + (check (not (session)) "Enter defaults to Cancel") + (check (equalp snapshot (lime.persistence:snapshot-world (world))) "cancel retains Activity and arrangements")) + (lime.x11:backend-open-command-palette backend) + (key #\a) (key #\d) + (choose '(:delete-activity "old")) + (choose '(:confirm-delete-activity "old")) + (check (not (session)) "confirmed deletion closes menu") + (check (not (find "old" (lime.core:list-activities (world)) :key #'lime.core:activity-id :test #'equal)) "Activity removed") + (check (equal "work" (lime.core:presentation-activity-id (current "left"))) "left Head unchanged") + (check (equal "chill" (lime.core:presentation-activity-id (current "right"))) "right Head unchanged") + (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "all real windows retained") + (check (eq :viewable (xlib:window-map-state a)) "visible client stays visible") + (check (eq :unmapped (xlib:window-map-state b)) "hidden client stays hidden") + (lime.x11:backend-save-session backend) + (lime.x11:stop-backend backend) + (setf backend nil) + (start) (pump) + (check (not (find "old" (lime.core:list-activities (world)) :key #'lime.core:activity-id :test #'equal)) "deleted Activity stays deleted after restart") + (check (equal "chill" (lime.core:client-activity-id (lime.core:find-client (world) aid))) "new home survives restart") + (check (not (lime.core:client-shared-p (lime.core:find-client (world) aid))) "private flag survives restart") + (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend aid)) "private lease restored on right") + (check (and (eq :viewable (xlib:window-map-state a)) (>= (xlib:drawable-x a) 600)) "private window restored in place") + (check (null (lime.core:view-placements (lime.core:find-view (world) "code"))) "old checkpoint pruning persists") + (check (equal (list aid) (mapcar #'lime.core:placement-client-id + (lime.core:view-placements (lime.core:find-view (world) "music")))) "kept checkpoint persists") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no deletion menu errors") + (check (lime.core:validate-world (world)) "post-deletion restored world valid") + (format t "~&Membership smoke: ~D checks passed.~%" checks)))) + (when backend (ignore-errors (lime.x11:stop-backend backend))) + (when clients (ignore-errors (xlib:close-display clients :abort t))) + (uiop:terminate-process server) + (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Membership smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-membership.lisp b/test/x11-membership.lisp new file mode 100644 index 0000000..b45984d --- /dev/null +++ b/test/x11-membership.lisp @@ -0,0 +1,281 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(defmacro with-membership-backend ((backend world) &body body) + `(let* ((,backend (make-head-bar-fixture)) (,world (x11-backend-world ,backend)) + (original (symbol-function 'apply-active-presentation))) + (create-activity ,world "chill" "Chill") + (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")) + (open-activity-draft ,world "other" "chill") + (unwind-protect + (progn + (setf (symbol-function 'apply-active-presentation) (lambda (b) b)) + ,@body) + (setf (symbol-function 'apply-active-presentation) original)))) + +(test cross-activity-head-send-needs-explicit-confirmation + (with-membership-backend (backend world) + (let* ((before (lime.persistence:snapshot-world world)) + (source (current-presentation world "main")) + (target (current-presentation world "other")) + (result (lime.x11::%ui-request-client-send backend "other"))) + (is (eq :replace (ui-result-kind result))) + (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result))))) + (is (search "Development to Chill" (lime.ui:ui-result-message result))) + (is (search "saved views" (ui-candidate-detail (first (ui-result-candidates result))))) + (is (equalp before (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action (first (ui-result-candidates result))))))) + (is (equalp before (lime.persistence:snapshot-world world))) + (is (equal "main" (x11-backend-focused-head-id backend))) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates result))))))) + (is (equal "chill" (client-activity-id (find-client world "editor")))) + (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor"))) + (is (equal "other" (lime.x11:x11-backend-focused-head-id backend))) + (is (equal "chill" (lime.x11::x11-backend-activity-id backend))) + (is (eq source (current-presentation world "main"))) + (is (eq target (current-presentation world "other"))) + (is (equal "terminal" (presentation-focus-client-id source))) + (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code"))))) + (is (validate-world world)) + (let ((snapshot (lime.persistence:snapshot-world world))) + (is (equalp snapshot (lime.persistence:snapshot-world (lime.persistence:restore-world snapshot)))))))) + +(test head-send-confirmations-reject-stale-context-without-retargeting + (dolist (change '(:head :focus :target :hide :retire :shared :new-client)) + (with-membership-backend (backend world) + (let* ((result (lime.x11::%ui-request-client-send backend "other")) + (action (ui-candidate-action (second (ui-result-candidates result))))) + (ecase change + (:head (setf (lime.x11:x11-backend-focused-head-id backend) "other")) + (:focus (focus-client-on-presentation world "terminal" (presentation-id (current-presentation world "main")))) + (:target (open-activity-draft world "other" "development")) + (:hide (backend-hide-client backend "editor")) + (:retire (retire-client world "editor")) + (:shared (set-client-shared world "editor" t)) + (:new-client (create-client world "new" "chill"))) + (let ((before (lime.persistence:snapshot-world world)) + (head (x11-backend-focused-head-id backend))) + (is (eq :keep-open (ui-result-kind (funcall action)))) + (is (equal head (x11-backend-focused-head-id backend))) + (is (equalp before (lime.persistence:snapshot-world world)))))))) + +(test same-activity-and-shared-head-sends-stay-immediate-and-do-not-rehome + (dolist (shared-p '(nil t)) + (with-membership-backend (backend world) + (if shared-p (set-client-shared world "editor" t) + (open-activity-draft world "other" "development")) + (set-presentation-layout-mode world (presentation-id (current-presentation world "other")) :monocle) + (setf (lime.x11::x11-backend-focus-root-override-p backend) t) + (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "other")))) + (is (equal "development" (client-activity-id (find-client world "editor")))) + (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor"))) + (is (equal "editor" (presentation-focus-client-id (current-presentation world "other")))) + (is (equal "other" (lime.x11:x11-backend-focused-head-id backend))) + (is (equal (if shared-p "chill" "development") (lime.x11::x11-backend-activity-id backend))) + (is-false (lime.x11::x11-backend-focus-root-override-p backend)) + (is (equal "terminal" (presentation-focus-client-id (current-presentation world "main")))) + (is (equal '("editor" "terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code"))))) + (is (validate-world world))))) + +(test head-send-to-self-or-empty-source-is-a-no-op + (with-membership-backend (backend world) + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "main")))) + (is (equal "main" (x11-backend-focused-head-id backend))) + (is (equalp before (lime.persistence:snapshot-world world)))) + (setf (lime.x11:x11-backend-focused-head-id backend) "other") + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (lime.x11::%ui-request-client-send backend "main")))) + (is (equal "other" (x11-backend-focused-head-id backend))) + (is (equalp before (lime.persistence:snapshot-world world)))))) + +(test membership-commands-live-under-windows-and-move-stays-on-current-activity + (with-membership-backend (backend world) + (let* ((window (find :window (lime.x11::%ui-key-path backend) :key #'ui-key-node-id)) + (move (find :move-client-to-activity (ui-key-node-children window) :key #'ui-key-node-id)) + (share (find :set-client-shared (ui-key-node-children window) :key #'ui-key-node-id)) + (result (funcall (ui-key-node-action move)))) + (is (char= #\m (ui-key-node-key move))) + (is (char= #\s (ui-key-node-key share))) + (is (eq :replace (ui-result-kind result))) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action (first (ui-result-candidates result))))))) + (is (equal "development" (presentation-activity-id (current-presentation world "main")))) + (is (equal "chill" (client-activity-id (find-client world "editor")))) + ;; Portable destinations receive the window in their real arrangement, + ;; not in a second, hidden draft tied to the sending monitor. + (is-true (lease-for-client world "editor")) + (is (equal '("editor") (presentation-client-ids (current-presentation world "other")))) + (backend-activate-activity backend "chill" :head-id "main") + (is (equal '("editor") (presentation-leased-client-ids world (current-presentation world "main")))) + (is-true (validate-world world))))) + +(test stale-move-picker-does-not-act-on-another-window + (with-membership-backend (backend world) + (let* ((result (lime.x11::%ui-move-client-result backend "editor" "main")) + (choice (first (ui-result-candidates result)))) + (backend-hide-client backend "editor") + (let ((snapshot (lime.persistence:snapshot-world world))) + (signals invalid-transition (funcall (ui-candidate-action choice))) + (is (equalp snapshot (lime.persistence:snapshot-world world))))))) + +(test shared-picker-takes-only-explicitly-and-can-summon-an-unavailable-slot-back + (with-membership-backend (backend world) + (backend-set-client-shared backend "terminal" t) + (backend-select-head backend "other") + (let* ((candidate (find '(:show-hidden-client "terminal") (lime.x11::%ui-hidden-client-candidates backend) + :key #'ui-candidate-id :test #'equal)) + (snapshot (lime.persistence:snapshot-world world)) + (result (funcall (ui-candidate-action candidate)))) + (is (search "Shared" (ui-candidate-label candidate))) + (is (eq :replace (ui-result-kind result))) + (is (equalp snapshot (lime.persistence:snapshot-world world))) + (signals invalid-transition (backend-show-client backend "terminal")) + (is (equalp snapshot (lime.persistence:snapshot-world world))) + (funcall (ui-candidate-action (first (ui-result-candidates result)))) + (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "terminal")))) + (backend-select-head backend "main") + (is (find '(:show-hidden-client "terminal") (lime.x11::%ui-hidden-client-candidates backend) + :key #'ui-candidate-id :test #'equal)) + (backend-show-client-taking backend "terminal") + (is (equal "main" (lime.x11::ewmh-active-head-id-for-client backend "terminal"))) + (backend-hide-client backend "terminal") + (backend-select-head backend "other") + (backend-show-client backend "terminal") + (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "terminal"))) + (is-true (validate-world world)))) + +(test shared-head-transfer-and-attention-respect-the-existing-foreign-lease + (with-membership-backend (backend world) + (signals invalid-activity-membership (backend-transfer-focused-client-to-head backend "other")) + (is (equal "main" (x11-backend-focused-head-id backend))) + (backend-set-client-shared backend "editor" t) + (backend-transfer-focused-client-to-head backend "other") + (is (equal "other" (lime.x11::ewmh-active-head-id-for-client backend "editor"))) + (lime.x11::%attention-set-source backend "editor" 1 t) + (is (equal '("editor") (backend-attention-client-ids backend :activity-id "chill"))) + (backend-attend-client backend "editor") + (is (equal "other" (lime.x11::x11-backend-focused-head-id backend))) + (is (equal "chill" (presentation-activity-id (current-presentation world "other")))) + (is (equal "editor" (presentation-focus-client-id (current-presentation world "other")))) + (is-true (validate-world world)))) + +(test making-private-is-confirmed-and-keeps-the-current-activity + (with-membership-backend (backend world) + (backend-set-client-shared backend "editor" t) + (backend-show-client-taking backend "editor" :head-id "other") + (backend-save-view backend "chill/music" "Music" :head-id "other") + (let* ((snapshot (lime.persistence:snapshot-world world)) + (source (current-presentation world "main")) + (target (current-presentation world "other")) + (placements (presentation-placements target)) + (lease (lease-for-client world "editor")) + (result (lime.x11::%ui-set-client-sharing-result backend "editor" "other" nil))) + (is (eq :replace (ui-result-kind result))) + (is (search "Make private to Chill?" (lime.ui:ui-result-message result))) + (is (eq :cancel (ui-candidate-id (first (ui-result-candidates result))))) + (is (search "other Activities and their saved views" (ui-candidate-detail (second (ui-result-candidates result))))) + (is (equalp snapshot (lime.persistence:snapshot-world world))) + (funcall (ui-candidate-action (first (ui-result-candidates result)))) + (is (equalp snapshot (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates result))))))) + (is-false (client-shared-p (find-client world "editor"))) + (is (equal "chill" (client-activity-id (find-client world "editor")))) + (is (eq lease (lease-for-client world "editor"))) + (is (eq source (current-presentation world "main"))) + (is (eq target (current-presentation world "other"))) + (is (eq placements (presentation-placements target))) + (is (equal "editor" (presentation-focus-client-id target))) + (is (equal "other" (x11-backend-focused-head-id backend))) + (is (equal '("terminal") (mapcar #'placement-client-id (view-placements (find-view world "development/code"))))) + (is (equal '("editor") (mapcar #'placement-client-id (view-placements (find-view world "chill/music"))))) + (is-false (lime.x11::%ui-hidden-client-candidates backend)) + (backend-select-head backend "main") + (is-false (find '(:show-hidden-client "editor") (lime.x11::%ui-hidden-client-candidates backend) + :key #'ui-candidate-id :test #'equal)) + (signals invalid-transition (backend-show-client backend "editor")) + (is-true (validate-world world)) + (let ((saved (lime.persistence:snapshot-world world))) + (is (equalp saved (lime.persistence:snapshot-world (lime.persistence:restore-world saved)))))))) + +(test make-private-confirmation-rejects-changed-context + (dolist (change '(:head :focus :activity :hide :transfer :retire :shared :home)) + (with-membership-backend (backend world) + (backend-set-client-shared backend "editor" t) + (backend-show-client-taking backend "editor" :head-id "other") + (let* ((result (lime.x11::%ui-set-client-sharing-result backend "editor" "other" nil)) + (action (ui-candidate-action (second (ui-result-candidates result))))) + (ecase change + (:head (setf (x11-backend-focused-head-id backend) "main")) + ;; Even an adapter-only focus change without a model revision is stale. + (:focus (setf (presentation-focus-client-id (current-presentation world "other")) nil)) + (:activity (open-activity-draft world "other" "development")) + (:hide (backend-hide-client backend "editor")) + (:transfer (backend-show-client-taking backend "editor" :head-id "main")) + (:retire (retire-client world "editor")) + (:shared (set-client-shared world "editor" nil)) + (:home (move-client-to-activity world "editor" "chill"))) + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :keep-open (ui-result-kind (funcall action)))) + (is (equalp before (lime.persistence:snapshot-world world)))))))) + +(test non-prompting-private-command-and-sharing-alias-keep-the-current-home + (dolist (explicit-head-p '(nil t)) + (with-membership-backend (backend world) + (backend-set-client-shared backend "editor" t) + (backend-show-client-taking backend "editor" :head-id "other") + (when explicit-head-p (backend-select-head backend "main")) + (let ((before (lime.persistence:snapshot-world world))) + (signals stale-transition-plan + (backend-make-client-private backend "editor" :head-id "other" :expected-revision -1)) + (is (equalp before (lime.persistence:snapshot-world world))) + (when explicit-head-p + (signals invalid-transition (backend-set-client-shared backend "editor" nil)) + (is (equalp before (lime.persistence:snapshot-world world))))) + (if explicit-head-p (backend-make-client-private backend "editor" :head-id "other") + (backend-set-client-shared backend "editor" nil)) + (is (equal "chill" (client-activity-id (find-client world "editor")))) + (is (equal (if explicit-head-p "main" "other") (x11-backend-focused-head-id backend))) + (is-false (client-shared-p (find-client world "editor"))) + (is (validate-world world))))) + +(test delete-activity-is-discoverable-confirmed-and-non-mutating-until-approved + (with-membership-backend (backend world) + (create-activity world "old" "Old") + (let* ((node (find :activity (lime.x11::%ui-key-path backend) :key #'ui-key-node-id)) + (delete-node (find :delete-activity (ui-key-node-children node) :key #'ui-key-node-id)) + (snapshot (lime.persistence:snapshot-world world)) + (picker (funcall (ui-key-node-action delete-node)))) + (is (char= #\d (ui-key-node-key delete-node))) + (is (find :delete-activity (lime.x11::%command-palette-candidates backend) :key #'ui-candidate-id)) + (let* ((candidate (find '(:delete-activity "old") (ui-result-candidates picker) :key #'ui-candidate-id :test #'equal)) + (confirmation (funcall (ui-candidate-action candidate)))) + (is (eq :replace (ui-result-kind confirmation))) + (is (eq :cancel (ui-candidate-id (first (ui-result-candidates confirmation))))) + (funcall (ui-candidate-action (first (ui-result-candidates confirmation)))) + (is (equalp snapshot (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (funcall (ui-candidate-action (second (ui-result-candidates confirmation))))))) + (signals unknown-entity (find-activity world "old")) + (is (equal "development" (presentation-activity-id (current-presentation world "main")))) + (is (equal "chill" (presentation-activity-id (current-presentation world "other")))))))) + +(test activity-delete-menu-explains-blockers-and-rejects-stale-confirmations + (with-membership-backend (backend world) + (let ((snapshot (lime.persistence:snapshot-world world))) + (is (eq :keep-open (ui-result-kind (lime.x11::%ui-delete-activity-result backend "development")))) + (is (eq :keep-open (ui-result-kind (lime.x11::%ui-delete-activity-result backend "chill")))) + (is (equalp snapshot (lime.persistence:snapshot-world world)))) + (create-activity world "old" "Old") + (let* ((confirmation (lime.x11::%ui-delete-activity-result backend "old")) + (action (ui-candidate-action (second (ui-result-candidates confirmation))))) + (create-client world "new" "old") + (let ((snapshot (lime.persistence:snapshot-world world))) + (is (eq :keep-open (ui-result-kind (funcall action)))) + (is (equalp snapshot (lime.persistence:snapshot-world world)))) + (retire-client world "new") + (delete-activity world "old") + (create-activity world "old" "New activity, reused id") + (is (eq :keep-open (ui-result-kind (funcall action)))) + (is (equal "New activity, reused id" (activity-name (find-activity world "old"))))))) diff --git a/test/x11-navigation-smoke.lisp b/test/x11-navigation-smoke.lisp new file mode 100644 index 0000000..3df7953 --- /dev/null +++ b/test/x11-navigation-smoke.lisp @@ -0,0 +1,261 @@ +;;;; Real numeric key grabs, lease prompts, and restart persistence on OWN Xvfb. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(lime.config:defconfiguration navigation-smoke-config (:navigation-keys)) + +(handler-case + (let* ((directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) + (uiop:run-program '("mktemp" "-d" "/tmp/lime-navigation-XXXXXX") :output :string)))) + (path (merge-pathnames "session.sexp" directory)) + (server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 600 :height 622) + (lime.x11:make-x11-head :head-id "right" :x 600 :y 0 :width 600 :height 622)))) + (setf clients (xlib:open-default-display display-name)) + (labels ((check (truth label) (assert truth () "Navigation: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (&optional (head "left")) (lime.core:current-presentation (world) head)) + (activity () (lime.core:presentation-activity-id (current))) + (view () (lime.core:presentation-source-view-id (current))) + (session () (lime.x11::x11-backend-ui-session backend)) + (start () + (setf backend (lime.x11:start-lime :display-name display-name :heads heads + :install-default-keybindings-p nil :session-file path)) + (lime.x11:apply-lime-configuration backend navigation-smoke-config)) + (stop () (lime.x11:stop-backend backend) (setf backend nil)) + (pump () + (xlib:display-finish-output clients) + (let ((turns 0) (display (lime.x11::x11-backend-display backend))) + (lime.x11:run-event-loop backend :timeout 0.005 + :before-event (lambda (b) + (assert (< (incf turns) 500) () "Navigation event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (tap (number &optional shift-p) + (let* ((display (lime.x11::x11-backend-display backend)) + (super (first (nth-value 6 (xlib:modifier-mapping display)))) + (shift (first (nth-value 0 (xlib:modifier-mapping display)))) + (key (xlib:keysym->keycodes display (+ (char-code #\0) (mod number 10))))) + (check (and super shift key) "physical modifier and digit keycodes found") + (xlib/xtest:fake-key-event clients super t) + (when shift-p (xlib/xtest:fake-key-event clients shift t)) + (xlib/xtest:fake-key-event clients key t) + (xlib/xtest:fake-key-event clients key nil) + (when shift-p (xlib/xtest:fake-key-event clients shift nil)) + (xlib/xtest:fake-key-event clients super nil) + (pump))) + (choose (id) + (let ((candidate (find id (lime.ui:ui-session-candidates (session)) + :key #'lime.ui:ui-candidate-id :test #'equal))) + (check candidate (format nil "collision choice ~S exists" id)) + (lime.x11::%perform-ui-action backend (list :candidate candidate))) + (pump)) + (click-region (head region) + (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend))) + (window (lime.x11::x11-head-bar-window bar))) + (xlib/xtest:fake-motion-event clients + (+ (xlib:drawable-x window) + (floor (+ (lime.x11::x11-head-bar-hit-region-left region) + (lime.x11::x11-head-bar-hit-region-right region)) 2)) + (+ (xlib:drawable-y window) 10)) + (pump) + (check (lime.x11::x11-head-bar-pointer-hand-p bar) "activity target has hand cursor") + (xlib/xtest:fake-button-event clients 1 t) + (xlib/xtest:fake-button-event clients 1 nil) + (pump))) + (click-activity (head id) + (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend))) + (entries (lime.x11::%bar-activity-entries backend head)) + (index (position id entries :key (lambda (e) (getf e :id)) :test #'equal)) + (region (nth (1+ index) (lime.x11::x11-head-bar-hit-regions bar)))) + ;; This fixture has only two entries at this point; no + ;; clipping/overflow is allowed to hide a wrong target. + (check (= (- (lime.x11::x11-head-bar-hit-region-right region) + (lime.x11::x11-head-bar-hit-region-left region)) + (lime.x11::%text-width (lime.x11::x11-head-bar-font bar) + (getf (nth index entries) :text))) + "click region matches entire measured Activity label") + (click-region head region))) + (spawn () + (let ((window (xlib:create-window + :parent (xlib:screen-root (xlib:display-default-screen clients)) + :x 0 :y 0 :width 100 :height 100))) + (xlib:map-window window) (pump) + (lime.x11::%backend-client-id backend window)))) + (start) + (lime.x11:backend-select-head backend "left") + (let ((right-id (lime.core:presentation-id (current "right")))) + (check (= 1 (lime.x11:backend-activity-slot backend "scratch")) "Scratch starts at 1") + (lime.x11:backend-start-activity backend "work" "Work") + (let* ((a (spawn)) + (code (lime.x11:backend-save-named-view backend "Code")) + (code-id (lime.core:presentation-source-view-id code)) + (b (spawn)) + (dirty-id (lime.core:presentation-id (current)))) + (lime.core:create-view (world) "work/docs" "work" "Docs" + (list (lime.core:make-placement :client-id b))) + (lime.x11:backend-set-view-slot backend "work/docs" 3) + (check (lime.core:presentation-dirty-p (current)) "Code has unsaved new window") + (lime.x11:backend-start-activity backend "chill" "Chill") + (lime.x11:backend-save-named-view backend "Play") + (tap 2) + (check (equal "work" (activity)) "Super-2 selects Work") + (check (equal dirty-id (lime.core:presentation-id (current))) "returns to identical dirty presentation") + (check (equal code-id (view)) "Activity return preserves selected View") + (check (member b (lime.core:presentation-client-ids (current)) :test #'equal) "unsaved window retained") + (check (equal right-id (lime.core:presentation-id (current "right"))) "other Head unchanged") + (check (not (session)) "successful switch has no menu") + (let ((before (lime.persistence:snapshot-world (world)))) + (tap 2) (tap 1 t) + (check (equalp before (lime.persistence:snapshot-world (world))) "current Activity/View keys do not reset edits")) + (tap 3 t) + (check (equal "work/docs" (view)) "Super-Shift-3 recalls local Docs") + (check (equal (list b) (lime.core:presentation-client-ids (current))) "checkpoint contents recalled") + (tap 3) + (tap 1 t) + (check (equal "chill" (activity)) "same shifted number stays in Chill") + (check (equal "Play" (lime.core:view-name (lime.core:find-view (world) (view)))) "local 1 means Chill's Play") + (lime.x11:backend-set-activity-slot backend "work" 3) + (lime.x11:backend-set-view-slot backend code-id 10) + (tap 3) (tap 10 t) + (check (equal code-id (view)) "Super-3 follows Activity order; Super-Shift-0 uses stable View slot 10") + ;; A distinct View containing A may hold the lease on right. + (lime.core:create-view (world) "work/right" "work" "Right" + (list (lime.core:make-placement :client-id a))) + (lime.x11:backend-extend-activity-to-head backend "work" "right") + (lime.x11:backend-activate-view backend "work/right" :head-id "right" :policy :take) + (tap 3 t) + (let ((before (lime.persistence:snapshot-world (world)))) + (tap 10 t) + (check (session) "contested checkpoint opens conflict picker") + (check (equalp before (lime.persistence:snapshot-world (world))) "conflict does not steal or mutate") + (choose :cancel) + (check (equalp before (lime.persistence:snapshot-world (world))) "cancel leaves both Heads alone")) + (tap 10 t) + (choose (list :activate-partially code-id)) + (check (member a (lime.core:presentation-unavailable-client-ids (current)) :test #'equal) + "partial recall leaves leased window elsewhere") + ;; Activity return keeps current locations, not omitted View requests. + (tap 2) + (tap 3) + (check (not (session)) "Activity resume needs no conflict menu") + (check (null (lime.core:presentation-client-ids (current))) "partial arrangement stays empty") + (check (equal "right" (lime.x11::ewmh-active-head-id-for-client backend a)) "Activity resume leaves other Head's window alone") + ;; Recalling the saved checkpoint is a distinct, explicit restore. + (tap 3 t) + (tap 10 t) + (choose (list :activate-taking code-id)) + (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend a)) "explicit take moves one lease") + (check (null (lime.core:presentation-client-ids (current "right"))) "source no longer retains a claim") + (lime.core:set-presentation-layout-mode (world) (lime.core:presentation-id (current)) :monocle) + (lime.x11:apply-active-presentation backend) + ;; Never mount the SAME View on two Heads, even empty/partial. + (lime.x11:backend-select-head backend "right") + (lime.x11:backend-select-view-slot backend 10) + (check (session) "already-mounted View gives visible explanation") + (check (search "already open" (lime.ui:ui-session-status (session))) "mount conflict explained") + (lime.x11:backend-close-command-palette backend) + (lime.x11:backend-select-head backend "left") + (check (equal "Work" (lime.x11::%bar-presentation-label backend "left")) "bar shows Activity without checkpoint suffix") + (check (lime.core:presentation-dirty-p (current)) "bar does not clear dirty edits") + (let ((slots (lime.x11:backend-navigation-slots backend))) + (lime.x11:backend-save-session backend) + (stop) (start) (pump) + (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "new session schema restores") + (check (equal slots (lime.x11:backend-navigation-slots backend)) "slot assignments survive restart") + (tap 2) (tap 3) + (check (equal code-id (view)) "last View resumes after restart") + (check (equal "Work" (lime.x11::%bar-presentation-label backend "left")) + "Activity-only bar survives persistence") + (check (lime.core:presentation-dirty-p (current)) "dirty edits survive navigation and persistence")) + (lime.x11:backend-switch-to-activity backend "scratch") + (lime.x11:backend-delete-activity backend "chill") + (check (= 2 (lime.x11:backend-activity-slot backend "work")) "deleting the middle Activity shifts Work to position 2") + (tap 2) + (check (equal "work" (activity)) "Super-2 now selects the second Activity") + (check (= 10 (lime.x11:backend-view-slot backend code-id)) "Activity compaction leaves View slots alone") + (let ((slots (lime.x11:backend-navigation-slots backend))) + (lime.x11:backend-save-session backend) + (stop) (start) (pump) + (check (equal slots (lime.x11:backend-navigation-slots backend)) "compacted order survives restart")) + (lime.x11:backend-start-activity backend "game" "A new Game") + (check (= 3 (lime.x11:backend-activity-slot backend "game")) "new Activity appends even with an earlier alphabetical name") + (tap 2) (tap 3) + (check (equal "game" (activity)) "Super-3 selects newly appended Activity") + (tap 2) + (lime.x11:backend-delete-activity backend "game") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no key dispatch errors") + (check (lime.core:validate-world (world)) "world invariants hold") + ;; Actual pointer events use the clicked Head, restore its + ;; dirty arrangement, and preserve the other Head's state. + (let ((right-id (lime.core:presentation-id (current "right")))) + (click-activity "left" "work") + (check (equal "work" (activity)) "bar click resumes Work") + (check (equal code-id (view)) "bar click restores dirty Code") + (check (equal right-id (lime.core:presentation-id (current "right"))) "bar does not switch other Head") + (let ((before (lime.persistence:snapshot-world (world)))) + (click-activity "left" "work") + (check (equalp before (lime.persistence:snapshot-world (world))) "active tab click does not reset checkpoint") + (check (not (eq :pointer-root (xlib:input-focus clients))) "active tab restores client input focus"))) + (click-activity "right" "scratch") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "offset right bar selects right Head") + (check (equal "scratch" (lime.core:presentation-activity-id (current "right"))) "right tab switches only right Activity") + (let ((left-id (lime.core:presentation-id (current)))) + (click-activity "right" "work") + (check (not (session)) "bar return has no stale lease conflict") + (check (null (lime.core:presentation-client-ids (current "right"))) "moved window is absent from old layout") + (check (equal left-id (lime.core:presentation-id (current))) "bar return leaves other activity unchanged") + (check (equal "left" (lime.x11::ewmh-active-head-id-for-client backend a)) "bar return does not reclaim moved window")) + (lime.x11:backend-select-head backend "left") + ;; Simulate a session produced before navigation existed. + (stop) + (let ((store (lime.persistence:open-session-store path))) + (unwind-protect + (let ((data (lime.persistence:read-session-store store))) + (remf data :navigation) + (remf data :activity-navigation) + (setf (getf data :version) 1) + (lime.persistence:write-session-store store data)) + (lime.persistence:close-session-store store))) + (start) (pump) + (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "legacy session migrates") + (check (= 1 (lime.x11:backend-activity-slot backend "scratch")) "legacy Scratch gets first slot") + (check (= 2 (lime.x11:backend-activity-slot backend "work")) "legacy remaining Activity gets second position") + (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) "migration reconnects real windows") + ;; Many long names must not push the active tab off the bar. + (dotimes (n 15) + (lime.core:create-activity (world) (format nil "extra~D" n) + (format nil "Long extra activity ~D" n))) + (lime.x11::apply-active-presentation backend) + (pump) + (let ((tenth (first (nth 9 (getf (lime.x11:backend-navigation-slots backend) :activities))))) + (tap 10) + (check (equal tenth (activity)) "Super-0 still selects position 10 with many Activities") + (tap 2)) + (let* ((bar (gethash "left" (lime.x11::x11-backend-head-bars backend))) + (regions (lime.x11::x11-head-bar-hit-regions bar)) + (overflow (nth (- (length regions) 2) regions))) + (check (= (lime.x11::%text-width (lime.x11::x11-head-bar-font bar) "…") + (- (lime.x11::x11-head-bar-hit-region-right overflow) + (lime.x11::x11-head-bar-hit-region-left overflow))) "overflow gets its own measured target") + (click-region "left" overflow) + (check (every (lambda (c) (eq :activity (first (lime.ui:ui-candidate-id c)))) + (lime.ui:ui-session-candidates (session))) "overflow shows only Activities") + (check (= 17 (length (lime.ui:ui-session-candidates (session)))) "overflow retains all Activities") + (choose '(:activity "extra14")) + (check (equal "extra14" (activity)) "overflow can reach clipped Activity")) + (check (null (lime.x11::x11-backend-last-command-error backend)) "bar navigation has no errors") + (format t "~&Navigation smoke: ~D checks passed.~%" checks))))) + (when backend (ignore-errors (lime.x11:stop-backend backend))) + (when clients (ignore-errors (xlib:close-display clients :abort t))) + (uiop:terminate-process server) (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Navigation smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-navigation.lisp b/test/x11-navigation.lisp new file mode 100644 index 0000000..6fd2a7d --- /dev/null +++ b/test/x11-navigation.lisp @@ -0,0 +1,266 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(lime.config:defconfiguration numbered-navigation-fixture + (:navigation-keys)) + +(test numbered-navigation-expands-to-configurable-ordinary-bindings + (let ((config numbered-navigation-fixture)) + (is (= 20 (length (lime-configuration-commands config)))) + (is (= 20 (length (lime-configuration-bindings config)))) + (is (eq config (lime.x11::%validate-lime-configuration config))) + (dolist (kind '(:activity :view)) + (loop for n from 1 to 10 for key across "1234567890" do + (let* ((id (intern (format nil "NAVIGATE-~A-~D" kind n) :keyword)) + (binding (find id (lime-configuration-bindings config) :key #'configuration-binding-command-id))) + (is (eql key (configuration-binding-key binding))) + (is (equal (if (eq kind :view) '(:mod-4 :shift) '(:mod-4)) + (configuration-binding-modifiers binding))))))) + (signals error + (macroexpand-1 '(lime.config:defconfiguration invalid-navigation (:navigation-keys :typo t))))) + +(test activity-positions-compact-while-view-slots-stay-local-and-stable + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "scratch" "Scratch") + (create-activity world "chill" "Chill") + (create-view world "chill/code" "chill" "Code" nil) + (let ((before (lime.persistence:snapshot-world world))) + (is (= 1 (backend-activity-slot backend "scratch"))) + (is (= 2 (backend-activity-slot backend "chill"))) + (is (= 3 (backend-activity-slot backend "development"))) + (is (= 1 (backend-view-slot backend "development/code"))) + (is (= 1 (backend-view-slot backend "chill/code"))) + (backend-set-activity-slot backend "development" 1) + (is (= 1 (backend-activity-slot backend "development"))) + (is (= 3 (backend-activity-slot backend "scratch"))) + (is (equalp before (lime.persistence:snapshot-world world)))) + (delete-activity world "chill") + (is (= 2 (backend-activity-slot backend "scratch"))) + (create-activity world "new" "A new task") + (is (= 3 (backend-activity-slot backend "new"))) + (create-view world "development/docs" "development" "Docs" nil) + (is (= 2 (backend-view-slot backend "development/docs"))) + (backend-set-view-slot backend "development/docs" 1) + (is (= 1 (backend-view-slot backend "development/docs"))) + (is (= 2 (backend-view-slot backend "development/code"))) + (signals invalid-transition (backend-set-activity-slot backend "new" 0)) + (signals invalid-transition (backend-set-activity-slot backend "new" 4)) + (loop for n from 1 to 12 do (create-activity world (format nil "extra~D" n) "Extra")) + (is (= 15 (length (getf (backend-navigation-slots backend) :activities)))) + (is (null (backend-view-slot backend "chill/code"))) + (let ((before (lime.persistence:snapshot-world world))) + (is (null (backend-select-activity-slot backend 999))) + (is (null (backend-select-view-slot backend 999))) + (is (equalp before (lime.persistence:snapshot-world world)))))) + +(test navigation-persistence-validates-scoped-uniqueness-and-resume-targets + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "chill" "Chill") + (create-view world "chill/code" "chill" "Code" nil) + (backend-set-activity-slot backend "development" 2) + (backend-set-view-slot backend "development/code" 10) + (let* ((data (lime.x11::%navigation-snapshot backend)) + (restored (lime.x11::%navigation-read-data data world))) + (is (equal data (list :activities (lime.x11::navigation-state-activities restored) + :views (lime.x11::navigation-state-views restored) + :resume (lime.x11::navigation-state-resume restored)))) + (dolist (bad '((:activities (("development" 1) ("chill" 1)) :views nil :resume nil) + (:activities (("development" 0)) :views nil :resume nil) + (:activities (("missing" 1)) :views nil :resume nil) + (:activities nil :views (("development/code" 1) ("development/code" 2)) :resume nil))) + (signals error (lime.x11::%navigation-read-data bad world))) + (let ((bad (copy-tree data))) + (setf (second (first (getf bad :resume))) "chill") + (signals error (lime.x11::%navigation-read-data bad world))) + (setf (gethash backend lime.x11::*backend-navigation-states*) restored) + (is (= 2 (backend-activity-slot backend "development"))) + (is (= 10 (backend-view-slot backend "development/code")))))) + +(test activity-compaction-preserves-order-without-mutating-input + (let* ((existing '(("c" 9) ("a" 1) ("removed" 4))) + (before (copy-tree existing)) + (result (lime.x11::%navigation-activity-slots existing '("new" "a" "c" "last")))) + (is (equal '(("a" 1) ("c" 2) ("new" 3) ("last" 4)) result)) + (is (equal before existing)) + (setf (second (first result)) 999) + (is (equal before existing)) + (is (null (lime.x11::%navigation-activity-slots existing nil))))) + +(test old-sparse-activity-shortcuts-load-in-bar-order-without-changing-view-slots + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "chill" "Chill") + (let* ((data '(:activities (("development" 8) ("chill" 3)) + :views (("development/code" 10)) :resume nil)) + (before-data (copy-tree data)) + (before-world (lime.persistence:snapshot-world world)) + (state (lime.x11::%navigation-read-data data world))) + (is (equal '(("chill" 1) ("development" 2)) (lime.x11::navigation-state-activities state))) + (is (equal before-data data)) + (setf (gethash backend lime.x11::*backend-navigation-states*) state) + (is (= 2 (backend-activity-slot backend "development"))) + (is (= 10 (backend-view-slot backend "development/code"))) + (is (equalp before-world (lime.persistence:snapshot-world world))) + (create-activity world "new" "Alphabetically first") + (is (= 3 (backend-activity-slot backend "new"))) + (let ((snapshot (lime.x11::%navigation-snapshot backend))) + (is (equal (getf snapshot :activities) + (lime.x11::navigation-state-activities (lime.x11::%navigation-read-data snapshot world)))))))) + +(test activity-deletion-compacts-before-append-even-without-an-intermediate-render + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "first" "A first") + (create-activity world "last" "Z last") + (backend-set-view-slot backend "development/code" 9) + (let ((state (lime.x11::%navigation-state backend))) + (is (equal '(("first" 1) ("development" 2) ("last" 3)) (lime.x11::navigation-state-activities state))) + (let ((generation (lime.x11::navigation-state-generation state))) + (delete-activity world "first") + (create-activity world "new" "A new") + (let ((before (lime.persistence:snapshot-world world))) + (is (equal '(("development" 1) ("last" 2) ("new" 3)) + (getf (backend-navigation-slots backend) :activities))) + (is (> (lime.x11::navigation-state-generation state) generation)) + (is (= 9 (backend-view-slot backend "development/code"))) + (dolist (head-id '("main")) + (is (equal '("development" "last" "new") + (mapcar (lambda (entry) (getf entry :id)) (lime.x11::%bar-activity-entries backend head-id))))) + (is (equalp before (lime.persistence:snapshot-world world)))))))) + +(test numbered-current-activity-and-view-do-not-reset-dirty-edits + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) + (p (current-presentation world "main"))) + (set-presentation-layout-mode world (presentation-id p) :monocle) + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind (backend-select-activity-slot backend 1)))) + (is (eq :close (ui-result-kind (backend-select-view-slot backend 1)))) + (is (equalp before (lime.persistence:snapshot-world world))) + (is (presentation-dirty-p p))))) + +(test navigation-session-envelope-migrates-v1-without-inventing-views + (let* ((world (make-world)) + (activity (create-activity world "scratch" "Scratch")) + (legacy (list :format :lime-session :version 1 + :world (lime.persistence:snapshot-world world) + :server-token (make-string 32 :initial-element #\A) + :clients nil :focused-head nil :focus-root nil))) + (is (equal (activity-id activity) + (activity-id (first (list-activities (lime.x11::%validate-session-envelope legacy)))))) + (let ((modern (copy-tree legacy))) + (setf (getf modern :version) 2 + (getf modern :navigation) '(:activities (("scratch" 1)) :views nil :resume nil)) + (is (null (activity-view-ids + (find-activity (lime.x11::%validate-session-envelope modern) "scratch")))) + (setf (getf modern :navigation) '(:activities (("missing" 1)) :views nil :resume nil)) + (signals error (lime.x11::%validate-session-envelope modern))))) + +(test activity-strip-highlights-the-local-activity-without-view-suffixes + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "chill" "Chill") + (create-head world "right") + (setf (gethash "right" (lime.x11::x11-backend-heads backend)) + (make-x11-head :head-id "right" :x 840 :y 30 :width 800 :height 600) + (lime.x11::x11-backend-head-ids backend) '("main" "right")) + (open-activity-draft world "right" "chill") + (backend-set-activity-slot backend "development" 1) + (let* ((before (lime.persistence:snapshot-world world)) + (left (lime.x11::%bar-activity-entries backend "main")) + (right (lime.x11::%bar-activity-entries backend "right"))) + (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) left))) + (is (equal '("Development" "Chill") (mapcar (lambda (e) (getf e :text)) right))) + (is (getf (first left) :active-p)) + (is (getf (second right) :active-p)) + (is (equalp before (lime.persistence:snapshot-world world)))) + (open-activity-draft world "right" "development") + (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "right")) :text))) + (is (equal "Development" (getf (first (lime.x11::%bar-activity-entries backend "main")) :text))))) + +(defun choose-view-update (result id) + (funcall (ui-candidate-action (find id (ui-result-candidates result) + :key #'ui-candidate-id :test #'equal)))) + +(test checkpoint-update-picker-is-local-explicit-and-nondestructive-until-confirmed + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) + (p (current-presentation world "main"))) + (create-view world "development/docs" "development" "Docs" nil) + (create-activity world "chill" "Chill") + (create-view world "chill/code" "chill" "Code" nil) + ;; The source label is not required, and must not silently pick the target. + (setf (presentation-source-view-id p) nil) + (set-presentation-layout-mode world (presentation-id p) :monocle) + (let* ((before (lime.persistence:snapshot-world world)) + (picker (lime.x11::%ui-view-update-picker-result backend)) + (confirmation (choose-view-update picker '(:update-view "development/docs")))) + (is (equal '((:update-view "development/code") (:update-view "development/docs")) + (mapcar #'ui-candidate-id (ui-result-candidates picker)))) + (is (lime.x11::%ui-update-current-view-candidate backend)) + (is (eq :cancel (ui-candidate-id (first (ui-result-candidates confirmation))))) + (is (search "Docs" (lime.ui:ui-result-message confirmation))) + (is (eq :close (ui-result-kind (choose-view-update confirmation :cancel)))) + (is (equalp before (lime.persistence:snapshot-world world))) + (is (eq :close (ui-result-kind + (choose-view-update confirmation '(:confirm-update-view "development/docs"))))) + (is (eq :monocle (view-layout-mode (find-view world "development/docs")))) + (is (equal (presentation-client-ids p) + (mapcar #'placement-client-id (view-placements (find-view world "development/docs")))))) + (is (eq :manual (view-layout-mode (find-view world "development/code")))) + (is (null (view-placements (find-view world "chill/code")))) + (is (eq p (current-presentation world "main"))) + (is (null (presentation-source-view-id p))) + (is (validate-world world)))) + +(test checkpoint-update-rejects-changed-arrangements-and-heads + (dolist (change '(:model :head)) + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend)) + (picker (lime.x11::%ui-view-update-picker-result backend)) + (confirmation (choose-view-update picker '(:update-view "development/code")))) + (ecase change + (:model (set-presentation-layout-mode world (presentation-id (current-presentation world "main")) :monocle)) + (:head (setf (lime.x11::x11-backend-focused-head-id backend) "other"))) + (let ((before (lime.persistence:snapshot-world world))) + (is (eq :keep-open (ui-result-kind (choose-view-update picker '(:update-view "development/code"))))) + (is (eq :keep-open (ui-result-kind (choose-view-update confirmation '(:confirm-update-view "development/code"))))) + (is (equalp before (lime.persistence:snapshot-world world))))))) + +(test checkpoint-update-picker-explains-an-empty-library + (let* ((backend (make-head-bar-fixture)) (world (x11-backend-world backend))) + (create-activity world "empty" "Empty") + (open-activity-draft world "main" "empty") + (let* ((before (lime.persistence:snapshot-world world)) + (result (lime.x11::%ui-view-update-picker-result backend))) + (is (null (ui-result-candidates result))) + (is (search "Save a new checkpoint first" (lime.ui:ui-result-message result))) + (is (null (lime.x11::%ui-update-current-view-candidate backend))) + (is (equalp before (lime.persistence:snapshot-world world)))))) + +(test activity-strip-fitting-is-bounded-ordered-and-keeps-the-active-tab + (let* ((entries (list (list :id "one" :text "1 One") + (list :id "two" :text "2 Two") + (list :id "three" :text "3 Three") + (list :id "four" :text "4 Four:Draft*" :active-p t) + (list :id "five" :text "5 Five"))) + (before (copy-tree entries)) + (measure (lambda (text) (* 5 (length text))))) + (loop for width from 0 to 360 by 9 do + (multiple-value-bind (text prefix used runs) + (lime.x11::%fit-bar-activities entries width measure #'lime.x11::%bar-short-text) + (declare (ignore text prefix)) + (is (<= 0 used width)) + (is (loop for run in runs always (<= 0 (getf run :x) (+ (getf run :x) (getf run :width)) width))) + (is (loop for (a b) on runs while b + always (< (+ (getf a :x) (getf a :width)) (getf b :x)))) + (when (>= width 45) + (is (find "four" runs :key (lambda (r) (getf (getf r :entry) :id)) :test #'equal))) + (when (>= width 300) + (is (= 5 (length runs))) + (is (notany (lambda (r) (getf r :overflow-p)) runs))))) + (is (equal entries before)) + (let* ((fit (lambda (ignored budget ignored-measure) + (declare (ignore ignored ignored-measure)) + (lime.x11::%fit-bar-activities entries budget measure #'lime.x11::%bar-short-text))) + (layout (lime.x11::%bar-text-layout + 420 "" "[]=" "Some window" (make-string 100 :initial-element #\s) measure + :label-fit fit :minimum-label-width 96))) + (is (getf layout :label-runs)) + (is (find-if (lambda (r) (getf r :overflow-p)) (getf layout :label-runs))) + (is (<= (getf layout :label-x) (getf layout :layout-x) (getf layout :title-left) + (getf layout :title-right) (getf layout :status-x)))))) diff --git a/test/x11-package.lisp b/test/x11-package.lisp new file mode 100644 index 0000000..ef78e31 --- /dev/null +++ b/test/x11-package.lisp @@ -0,0 +1,3 @@ +(defpackage #:lime.x11.test + (:use #:cl #:fiveam #:lime.core #:lime.ui #:lime.x11) + (:export #:run-tests)) diff --git a/test/x11-persistence-smoke.lisp b/test/x11-persistence-smoke.lisp new file mode 100644 index 0000000..3d7aa52 --- /dev/null +++ b/test/x11-persistence-smoke.lisp @@ -0,0 +1,199 @@ +;;;; Owned Xvfb only: disk restoration, surviving hidden clients, identity safety, +;;;; autosave, unavailable leases, topology changes, and corrupt/I/O-failing files. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/dev") + +(handler-case + (let* ((directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) (uiop:run-program '("mktemp" "-d" "/tmp/lime-persistence-XXXXXX") :output :string)))) + (path (merge-pathnames "session.sexp" directory)) + (server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x600x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (clients nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 500 :height 600) + (lime.x11:make-x11-head :head-id "right" :x 500 :y 0 :width 500 :height 600)))) + (setf clients (xlib:open-default-display display-name)) + (let* ((root (xlib:screen-root (xlib:display-default-screen clients))) + (windows (loop repeat 4 collect (xlib:create-window :parent root :x 10 :y 10 :width 100 :height 80 :border-width 7))) + (ids nil) (saved nil)) + (labels ((check (truth label) (assert truth () "Persistence: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (sync () (xlib:display-finish-output (lime.x11::x11-backend-display backend))) + (start (&optional (screens heads)) + (setf backend (lime.x11:start-lime :display-name display-name :heads screens :head-bar-height 0 + :install-default-keybindings-p nil :session-file path)) + (sync)) + (stop () (lime.x11:stop-backend backend) (setf backend nil)) + (status () (lime.x11:backend-session-status backend)) + (snapshot () (let ((data (lime.persistence:snapshot-world (world)))) + (remf data :revision) data)) + (crash () + ;; Deliberately do not remap hidden clients or save a new + ;; snapshot, like losing only the WM process, not X. + (lime.x11::%stop-session-persistence backend nil) + (xlib:close-display (lime.x11::x11-backend-display backend) :abort t) + (setf (lime.x11::x11-backend-display backend) nil backend nil)) + (pump-for (seconds) + (let ((end (+ (get-internal-real-time) (* seconds internal-time-units-per-second)))) + (lime.x11:run-event-loop backend :timeout 0.01 + :before-event (lambda (b) (when (>= (get-internal-real-time) end) + (setf (lime.x11::x11-backend-running-p b) nil))))))) + (start) + (check (not (getf (status) :blocked-p)) "fresh store enabled") + (lime.x11:backend-start-activity backend "work" "Work 日本語") + (dolist (window windows) + (xlib:display-finish-output clients) + (push (lime.x11:manage-window backend (xlib::lookup-window (lime.x11::x11-backend-display backend) + (xlib:window-id window))) ids)) + (setf ids (nreverse ids)) + (lime.x11:backend-hide-client backend (third ids)) + (lime.x11:backend-hide-client backend (fourth ids)) + (lime.core:toggle-client-floating (world) (lime.core:presentation-id (current "left")) (second ids)) + (lime.core:set-client-tile-weight (world) (lime.core:presentation-id (current "left")) (first ids) 3/2) + (lime.x11:backend-save-view backend "code" "Code") + (lime.x11:backend-activate-view backend "code") + (lime.core:create-view (world) "docs" "work" "Docs" + (mapcar (lambda (id) (lime.core:make-placement :client-id id)) + (list (third ids) (first ids))) + :layout-mode :monocle :focus-client-id (third ids)) + (lime.x11:backend-extend-activity-to-head backend "work" "right") + (lime.x11:backend-activate-view-partially backend "docs" :head-id "right") + (lime.x11:backend-save-viewset backend "desk" "Desk") + (lime.x11:backend-set-client-floating-geometry backend (second ids) :head-id "left" + :x 1/4 :y 1/3 :width 1/2 :height 1/2) + (lime.x11:backend-focus-client backend (third ids) :head-id "right") + (sync) + (setf saved (snapshot)) + (lime.x11:backend-save-session backend) + (check (probe-file path) "explicit save creates file") + (check (= 1 (getf (status) :completed)) "explicit save waits for durable write") + (check (eq :unmapped (xlib:window-map-state (fourth windows))) "hidden client really unmapped") + (stop) + (check (every (lambda (w) (eq :viewable (xlib:window-map-state w))) windows) "graceful stop remaps clients") + (start) + (check (= 4 (getf (getf (status) :restore) :matched)) "all surviving clients reconnected") + (check (equalp saved (snapshot)) "whole desk roundtrips exactly except revision") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "focused Head restored") + (check (equal (list (first ids)) (lime.core:presentation-unavailable-client-ids (current "right"))) + "partial view stays partial, no stolen lease") + (check (eq :unmapped (xlib:window-map-state (fourth windows))) "hidden client re-hidden after graceful restart") + (check (lime.core:validate-world (world)) "restored world valid") + ;; Save-on-exit is not the only persistence path. + (lime.x11:backend-start-activity backend "game" "Game" :head-id "right") + (pump-for 1.0) + (check (>= (getf (status) :completed) 1) "autosave runs without explicit save") + (let ((last (getf (status) :submitted))) + (pump-for 0.2) + (check (= last (getf (status) :submitted)) "unchanged state does not rewrite disk")) + (setf saved (snapshot)) + (crash) + (start) + (check (equalp saved (snapshot)) "autosaved drafts survive abrupt connection loss") + (check (= 4 (getf (getf (status) :restore) :matched)) "unmapped clients found after abrupt loss") + (check (null (gethash (xlib:window-id (fourth windows)) (lime.x11::x11-backend-pending-unmaps backend))) + "already-hidden restored client has no ghost unmap token") + (check (equal "game" (lime.core:presentation-activity-id (current "right"))) "unsaved Activity draft persisted") + ;; Missing output suspends rather than losing/moving that draft. + (stop) + (start (list (first heads))) + (check (equal '("left") (lime.x11:backend-head-ids backend)) "new topology respected") + (check (find-if (lambda (p) (and (equal "game" (lime.core:presentation-activity-id p)) + (null (lime.core:presentation-head-id p)))) + (loop for p being the hash-values of (lime.core::world-presentations (world)) collect p)) + "missing Head draft suspended") + (check (lime.core:find-viewset (world) "desk") "Viewset survives missing output") + (check (lime.core:validate-world (world)) "topology-restored world valid") + ;; A write error cannot replace the good file or kill the WM. + (let ((bytes (uiop:read-file-string path)) (original (symbol-function 'lime.persistence::%sync-path))) + (unwind-protect + (progn + (setf (symbol-function 'lime.persistence::%sync-path) + (lambda (p) (declare (ignore p)) (error "Injected disk failure"))) + (check (handler-case (progn (lime.x11:backend-save-session backend) nil) (error () t)) + "explicit save reports disk failure")) + (setf (symbol-function 'lime.persistence::%sync-path) original)) + (check (string= bytes (uiop:read-file-string path)) "failed write leaves previous file intact") + (check (getf (status) :write-error) "write failure inspectable") + (setf (lime.x11::session-persistence-last-attempt (lime.x11::x11-backend-session-persistence backend)) + (- (/ (get-internal-real-time) internal-time-units-per-second) 6)) + (pump-for 0.1) + (check (null (getf (status) :write-error)) "autosave retries after disk-error backoff") + (lime.x11:backend-save-session backend) + (check (null (getf (status) :write-error)) "explicit retry recovers")) + (stop) + ;; Matching XID alone is not enough, even on the same server. + (xlib:change-property (first windows) :_LIME_SESSION_CLIENT '(98 97 100) :STRING 8) + (xlib:display-finish-output clients) + (start (list (first heads))) + (check (member (first ids) (getf (getf (status) :restore) :missing) :test #'equal) + "reused/mismatched identity not reconnected") + (check (not (find (first ids) (lime.core:view-placements (lime.core:find-view (world) "code")) + :key #'lime.core:placement-client-id :test #'equal)) + "unverified client not smuggled into old checkpoint") + (stop) + (xlib:destroy-window (second windows)) + (xlib:display-finish-output clients) + (start (list (first heads))) + (check (member (second ids) (getf (getf (status) :restore) :missing) :test #'equal) "dead client retired safely") + (check (lime.core:find-view (world) "code") "empty named checkpoint retained") + (stop) + ;; Equivalent identity boundary to a fresh X server after logout. + (xlib:delete-property root :_LIME_SESSION_SERVER) + (xlib:display-finish-output clients) + (start (list (first heads))) + (check (not (getf (getf (status) :restore) :same-server-p)) "server epoch change detected") + (check (zerop (getf (getf (status) :restore) :matched)) "no stale-window reconnection across servers") + (check (lime.core:find-activity (world) "game") "named Activities survive different X session") + (check (lime.core:find-view (world) "docs") "named Views survive different X session") + (stop) + (let ((bad "(:format :lime-session :version 999)")) + (with-open-file (out path :direction :output :if-exists :supersede) (write-string bad out)) + (start) + (check (getf (status) :blocked-p) "bad file blocks autosave, not WM startup") + (check (getf (status) :restore-error) "restore error inspectable") + (check (handler-case (progn (lime.x11:backend-save-session backend) nil) (error () t)) + "explicit save needs authorization to replace rejected file") + (pump-for 1.0) + (stop) + (check (string= bad (uiop:read-file-string path)) "bad file not overwritten on autosave/exit") + (start) + (lime.x11:backend-save-session backend :replace-invalid-p t) + (check (not (getf (status) :blocked-p)) "explicit replacement re-enables persistence") + (stop)) + ;; Exercise the actual developer restart path, not just adapter calls. + (let ((session (lime.dev:start-development-session :display-name display-name :heads heads + :session-file path :start-repl-p nil :diagnostic-file nil))) + (unwind-protect + (progn + (lime.dev:with-development-backend (b session) + (lime.x11:backend-start-activity b "developer" "Developer") + (check (eq :success (xlib:grab-keyboard (lime.x11::x11-backend-root b))) + "install input grab before failed restart")) + (let ((original (symbol-function 'lime.persistence::%sync-path))) + (unwind-protect + (progn + (setf (symbol-function 'lime.persistence::%sync-path) + (lambda (p) (declare (ignore p)) (error "Injected pre-restart disk failure"))) + (check (handler-case (progn (lime.dev:restart-development-session session) nil) + (error () t)) "restart refuses to discard an unsaved desk") + (check (lime.x11::x11-backend-display (lime.dev:development-session-backend session)) + "failed pre-restart save keeps original X connection") + (check (eq :success (xlib:grab-keyboard root)) "failed restart releases old input grabs") + (xlib:ungrab-keyboard clients) + (xlib:display-finish-output clients)) + (setf (symbol-function 'lime.persistence::%sync-path) original))) + (lime.dev:restart-development-session session) + (lime.dev:with-development-backend (b session) + (check (lime.core:find-activity (lime.x11:x11-backend-world b) "developer") + "developer restart persists world"))) + (lime.dev:stop-development-session session))) + (format t "~&Live X11 persistence: ~D checks passed. Files: ~A~%" checks directory)))) + (when backend (lime.x11:stop-backend backend :save-session-p nil)) + (when clients (xlib:close-display clients)) + (uiop:terminate-process server) (uiop:wait-process server))) + (error (c) (format *error-output* "~&Persistence smoke failed: ~A~%" c) (uiop:quit 1))) diff --git a/test/x11-pointer-ui-smoke.lisp b/test/x11-pointer-ui-smoke.lisp new file mode 100644 index 0000000..d456b41 --- /dev/null +++ b/test/x11-pointer-ui-smoke.lisp @@ -0,0 +1,227 @@ +;;;; Real pointer events on an owned Xvfb: never moves the desktop's pointer. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (checks 0)) + (unwind-protect + (let ((number (parse-integer (read-line (uiop:process-info-output server))))) + (setf backend (lime.x11:start-lime :display-name (format nil ":~D" number) + :head-discovery :none)) + (let* ((display (lime.x11::x11-backend-display backend)) + (root (lime.x11::x11-backend-root backend))) + (labels ((check (truth label) (assert truth () "Pointer UI: ~A" label) (incf checks)) + (session () (lime.x11::x11-backend-ui-session backend)) + (overlay () (lime.x11::x11-backend-ui-overlay backend)) + (hand (window label) + (check (and (= 1 (xlib/xtest:compare-cursor + display window (xlib:cursor-id (lime.x11::x11-backend-hand-cursor backend)))) + (= 1 (xlib/xtest:compare-cursor display window))) label)) + (arrow (label) + (check (= 1 (xlib/xtest:compare-cursor display root)) label)) + (pump () + ;; Exercise the production dispatch, not duplicate routing + ;; in the test. Stop once all generated events are drained. + (let ((turns 0)) + (lime.x11:run-event-loop + backend :timeout 0.005 + :before-event + (lambda (backend) + (assert (< (incf turns) 100) () "Event queue did not settle.") + (xlib:display-finish-output display) + (unless (xlib:event-listen display) + (setf (lime.x11::x11-backend-running-p backend) nil)))))) + (move (x y) + (xlib/xtest:fake-motion-event display x y) + (pump)) + (button (code) + (xlib/xtest:fake-button-event display code t) + (xlib/xtest:fake-button-event display code nil) + (pump)) + (click (x y) (move x y) (button 1)) + (hit (action) + (or (find action (lime.x11::x11-ui-overlay-hit-regions (overlay)) + :key #'lime.x11::ui-hit-region-action :test #'equal) + (error "No hit region for ~S" action))) + (point-at (action) + (let ((hit (hit action)) (window (lime.x11::x11-ui-overlay-window (overlay)))) + (move (+ (xlib:drawable-x window) (lime.x11::ui-hit-region-x hit) + (floor (lime.x11::ui-hit-region-width hit) 2)) + (+ (xlib:drawable-y window) (lime.x11::ui-hit-region-y hit) + (floor (lime.x11::ui-hit-region-height hit) 2))))) + (activate (action) (point-at action) (button 1)) + (key (key) (activate (list :key key)))) + (pump) + (check (= 1 (xlib/xtest:compare-cursor + display root (xlib:cursor-id (lime.x11::x11-backend-root-cursor backend)))) + "root owns the left pointer") + (move 800 600) + (check (= 1 (xlib/xtest:compare-cursor display root)) "desktop displays that cursor") + ;; A client-specific cursor must still override the root default. + (let ((font (xlib:open-font display "cursor")) (cursor nil) (window nil)) + (unwind-protect + (progn + (setf cursor (xlib:create-glyph-cursor + :source-font font :source-char 0 :mask-font font :mask-char 1 + :foreground (xlib:make-color :red 0 :green 0 :blue 0) + :background (xlib:make-color :red 1 :green 1 :blue 1)) + window (xlib:create-window :parent root :x 600 :y 450 :width 100 :height 100 + :override-redirect :on :cursor cursor)) + (xlib:map-window window) + (move 650 500) + (check (= 1 (xlib/xtest:compare-cursor display window)) "application cursor wins") + (check (= 0 (xlib/xtest:compare-cursor display root)) "not forcibly the root cursor")) + (when window (xlib:destroy-window window)) + (when cursor (xlib:free-cursor cursor)) + (xlib:close-font font))) + (let* ((bar (gethash (first (lime.x11:backend-head-ids backend)) + (lime.x11::x11-backend-head-bars backend))) + (window (lime.x11::x11-head-bar-window bar)) + (regions (lime.x11::x11-head-bar-hit-regions bar))) + (move 15 10) + (hand window "logo uses the hand") + (move (lime.x11::x11-head-bar-hit-region-right (first regions)) 10) + (arrow "logo delimiter uses the arrow") + (move (lime.x11::x11-head-bar-hit-region-left (second regions)) 10) + (hand window "activity tab uses the hand") + (move (lime.x11::x11-head-bar-hit-region-left (third regions)) 10) + (hand window "layout control uses the hand") + (move 500 10) + (arrow "inert title uses the arrow") + ;; A widget's action may change while its text stays the same. + (let ((clickable-p t) + (action (lambda (&rest args) (declare (ignore args))))) + (lime.x11:backend-set-head-bar-status-providers + backend (list (lambda (backend head-id) + (declare (ignore backend head-id)) + (lime.x11:make-head-bar-segment :text "Music" + :click-action (and clickable-p action))))) + (let* ((region (car (last (lime.x11::x11-head-bar-hit-regions bar)))) + (x (floor (+ (lime.x11::x11-head-bar-hit-region-left region) + (lime.x11::x11-head-bar-hit-region-right region)) 2))) + (move x 10) + (hand window "clickable status uses the hand") + (setf clickable-p nil) + (lime.x11::render-head-bars backend) + (pump) + (arrow "inert widget restores arrow without pointer movement") + (setf clickable-p t) + (lime.x11::render-head-bars backend) + (pump) + (hand window "new widget action restores hand without movement")) + (lime.x11:backend-set-head-bar-status-providers backend nil) + (pump) + (arrow "removed widget restores arrow")) + (move 15 10) + (hand window "hand restored on bar re-entry") + (move 800 600) + (arrow "leaving the bar restores desktop arrow")) + ;; Start at the actual bar button, then navigate entirely by mouse. + (click 15 10) + (check (and (session) (eq :key-path (lime.ui:ui-session-mode (session)))) "logo opens menu") + (point-at '(:key #\w)) + (check (equal '(:key #\w) (lime.x11::x11-ui-overlay-hovered-action (overlay))) "entry hovers") + (hand (lime.x11::x11-ui-overlay-window (overlay)) "menu entry uses the hand") + (button 1) + (check (string= "Lime › w Windows" (lime.x11::%ui-menu-heading (session))) "click enters submenu") + (key :backspace) + (check (null (lime.ui:ui-session-key-path (session))) "Back goes up") + (key :tab) + (check (eq :search (lime.ui:ui-session-mode (session))) "Search button works") + (key :tab) + (check (eq :key-path (lime.ui:ui-session-mode (session))) "Menu returns to root") + (let ((mode (lime.ui:ui-session-mode (session)))) + (click 1 23) + (check (eq mode (lime.ui:ui-session-mode (session))) "blank overlay space is inert") + (arrow "blank menu space uses the arrow")) + (key #\v) + (key #\s) + (check (eq :prompt (lime.ui:ui-session-mode (session))) "click opens prompt") + (key :return) + (check (string= "Input is required." (lime.ui:ui-session-status (session))) "Confirm validates input") + (lime.ui:ui-session-handle-key (session) #\M) + (lime.x11::%render-command-palette backend) + (key :return) + (check (not (session)) "Confirm saves and closes") + (check (getf (lime.x11:backend-status backend) :source-view-id) "checkpoint was saved") + (click 15 10) + (key #\v) + (key #\o) + (check (eq :search (lime.ui:ui-session-mode (session))) "click opens scoped picker") + (activate (list :candidate (first (lime.ui:ui-session-candidates (session))))) + (check (not (session)) "click picks saved View") + ;; Result replacement, wheel selection, stale regions, and errors. + (let* ((runs 0) + (choice (lime.ui:make-ui-candidate + :label "Take this choice" :action (lambda () (incf runs) (lime.ui:ui-close-result)))) + (bad (lime.ui:make-ui-candidate :label "Fail safely" :action (lambda () (error "Test failure")))) + (picker (lime.ui:make-ui-candidate + :label "Choices" :action (lambda () (lime.ui:ui-replace-result (list choice bad)))))) + (lime.x11::%open-ui-session backend (lime.ui:make-ui-session (list picker))) + (point-at (list :candidate picker)) + (hand (lime.x11::x11-ui-overlay-window (overlay)) "search result uses the hand") + (lime.ui:ui-session-handle-key (session) #\z) + (lime.x11::%render-command-palette backend) + (pump) + (arrow "no matches restores arrow without movement") + (check (null (lime.x11::x11-ui-overlay-hovered-action (overlay))) "no stale result highlight") + (lime.ui:ui-session-handle-key (session) :backspace) + (lime.x11::%render-command-palette backend) + (pump) + (hand (lime.x11::x11-ui-overlay-window (overlay)) "restored results restore hand without movement") + (activate (list :candidate picker)) + (check (equal (list choice bad) (lime.ui:ui-session-candidates (session))) "picker replaces choices") + (check (not (find (list :candidate picker) (lime.x11::x11-ui-overlay-hit-regions (overlay)) + :key #'lime.x11::ui-hit-region-action :test #'equal)) "old hit discarded") + (button 5) + (check (= 1 (lime.ui:ui-session-selected-index (session))) "wheel moves selection") + (activate (list :candidate bad)) + (check (search "Test failure" (lime.ui:ui-session-status (session))) "click errors stay in menu") + (activate (list :candidate choice)) + (check (= 1 runs) "correct clicked action ran once") + (check (not (session)) "mouse choice closes")) + (let* ((head (gethash (first (lime.x11:backend-head-ids backend)) + (lime.x11::x11-backend-heads backend))) + (nodes (loop for i below 40 collect + (lime.ui:make-ui-key-node :key (code-char (+ 256 i)) + :label (format nil "Command ~D" i))))) + ;; A non-zero Head origin checks root-to-overlay coordinate conversion. + (setf (lime.x11:x11-head-x head) 110 (lime.x11:x11-head-y head) 80 + (lime.x11:x11-head-width head) 320 (lime.x11:x11-head-height head) 260) + (lime.x11::%open-ui-session backend (lime.ui:make-ui-session nil :key-path nodes :mode :key-path)) + (key :page-down) + (check (= 1 (lime.ui:ui-session-key-page (session))) "next-page button") + (button 5) + (check (= 2 (lime.ui:ui-session-key-page (session))) "wheel pages grid") + (key :page-up) + (check (= 1 (lime.ui:ui-session-key-page (session))) "previous-page button") + (dolist (hit (lime.x11::x11-ui-overlay-hit-regions (overlay))) + (check (and (<= 0 (lime.x11::ui-hit-region-x hit) + (+ (lime.x11::ui-hit-region-x hit) (lime.x11::ui-hit-region-width hit)) 320) + (<= 0 (lime.x11::ui-hit-region-y hit) + (+ (lime.x11::ui-hit-region-y hit) (lime.x11::ui-hit-region-height hit)) + (lime.x11::x11-ui-overlay-height (overlay)))) "clipped hit bounds")) + (point-at '(:key :escape)) + (hand (lime.x11::x11-ui-overlay-window (overlay)) "offset Head's Close button uses hand") + (move 900 600) + (check (null (lime.x11::x11-ui-overlay-hovered-action (overlay))) "leaving clears hover") + (arrow "leaving menu restores arrow") + (key :escape) + (check (not (session)) "Close button works on offset Head")) + (let ((other (xlib:open-default-display (format nil ":~D" number)))) + (unwind-protect + (let ((other-root (xlib:screen-root (xlib:display-default-screen other)))) + (lime.x11:backend-open-command-palette backend) + (check (eq :already-grabbed (xlib:grab-keyboard other-root)) "open menu holds keyboard") + (key :escape) + (check (eq :success (xlib:grab-keyboard other-root)) "closing releases keyboard")) + (xlib:close-display other))) + (lime.x11:stop-backend backend) + (check (null (lime.x11::x11-backend-root-cursor backend)) "cursor resource released") + (check (null (lime.x11::x11-backend-hand-cursor backend)) "hand cursor released") + (format t "~&Live X11 pointer/menu: ~D checks passed.~%" checks)))) + (when backend (lime.x11:stop-backend backend)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-portable-activities-smoke.lisp b/test/x11-portable-activities-smoke.lisp new file mode 100644 index 0000000..acb0a65 --- /dev/null +++ b/test/x11-portable-activities-smoke.lisp @@ -0,0 +1,139 @@ +;;;; Real windows, keyboard/bar navigation, geometry, and restart on OWN Xvfb. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(lime.config:defconfiguration portable-smoke-config (:navigation-keys)) + +(defun run-portable-activity-smoke () + (let ((server nil) (client nil) (backend nil) (checks 0)) + (unwind-protect + (let* ((directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) + (uiop:run-program '("mktemp" "-d" "/tmp/lime-portable-XXXXXX") :output :string)))) + (file (merge-pathnames "session.sexp" directory))) + (setf server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1200x700x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (let* ((name (format nil ":~D" (parse-integer (read-line (uiop:process-info-output server))))) + (heads (list (lime.x11:make-x11-head :head-id "left" :x 0 :y 0 :width 700 :height 700) + (lime.x11:make-x11-head :head-id "right" :x 700 :y 0 :width 500 :height 700)))) + (setf client (xlib:open-default-display name)) + (labels ((check (truth label) (assert truth () "Portable Activities: ~A" label) (incf checks)) + (world () (lime.x11:x11-backend-world backend)) + (current (head) (lime.core:current-presentation (world) head)) + (start () + (setf backend (lime.x11:start-lime :display-name name :heads heads :session-file file + :install-default-keybindings-p nil)) + (lime.x11:apply-lime-configuration backend portable-smoke-config)) + (pump () + (xlib:display-finish-output client) + (let ((count 0)) + (lime.x11:run-event-loop backend :timeout 0.005 + :before-event + (lambda (b) + (assert (< (incf count) 600) () "Event queue did not settle.") + (xlib:display-finish-output (lime.x11::x11-backend-display b)) + (unless (xlib:event-listen (lime.x11::x11-backend-display b)) + (setf (lime.x11::x11-backend-running-p b) nil)))))) + (spawn () + (let ((window (xlib:create-window :parent (xlib:screen-root (xlib:display-default-screen client)) + :x 0 :y 0 :width 150 :height 100))) + (xlib:map-window window) (pump) + (lime.x11::%backend-client-id backend window))) + (window (id) (gethash id (lime.x11::x11-backend-client-windows backend))) + (visible (id) (eq :viewable (xlib:window-map-state (window id)))) + (tap-activity (head activity) + (lime.x11:backend-select-head backend head) + (let* ((display (lime.x11::x11-backend-display backend)) + (super (first (nth-value 6 (xlib:modifier-mapping display)))) + (slot (lime.x11:backend-activity-slot backend activity)) + (code (xlib:keysym->keycodes display (+ (char-code #\0) slot)))) + (xlib/xtest:fake-key-event client super t) + (xlib/xtest:fake-key-event client code t) + (xlib/xtest:fake-key-event client code nil) + (xlib/xtest:fake-key-event client super nil) (pump))) + (click-activity (head activity) + (let* ((bar (gethash head (lime.x11::x11-backend-head-bars backend))) + (entries (lime.x11::%bar-activity-entries backend head)) + (index (position activity entries :key (lambda (e) (getf e :id)) :test #'equal)) + (region (nth (1+ index) (lime.x11::x11-head-bar-hit-regions bar))) + (bar-window (lime.x11::x11-head-bar-window bar))) + (xlib/xtest:fake-motion-event client + (+ (xlib:drawable-x bar-window) + (floor (+ (lime.x11::x11-head-bar-hit-region-left region) + (lime.x11::x11-head-bar-hit-region-right region)) 2)) 10) + (pump) (xlib/xtest:fake-button-event client 1 t) + (xlib/xtest:fake-button-event client 1 nil) (pump)))) + (start) + (lime.x11:backend-start-activity backend "work" "Work" :head-id "left") + (let ((browser (spawn)) (work (current "left"))) + (lime.x11:backend-select-head backend "right") + (lime.x11:backend-start-activity backend "chat" "Chat") + (let* ((discord (spawn)) (hidden (spawn)) (chat (current "right"))) + (lime.x11:backend-hide-client backend hidden) + (lime.x11:backend-save-named-view backend "Chat") + (lime.x11:backend-toggle-client-floating backend discord) + (let ((lease (lime.core:lease-for-client (world) discord)) + (placement (copy-tree (lime.core:placement-data (first (lime.core:presentation-placements chat)))))) + (tap-activity "left" "chat") + (check (eq chat (current "left")) "numeric key brings original arrangement") + (check (eq work (current "right")) "numeric key swaps displaced activity") + (check (visible discord) "Discord stays visible") + (check (visible browser) "browser stays visible") + (check (not (visible hidden)) "hidden window stays hidden") + (check (eq lease (lime.core:lease-for-client (world) discord)) "lease identity survives swap") + (check (equal placement (lime.core:placement-data (first (lime.core:presentation-placements chat)))) + "normalized floating geometry survives monitor size changes") + (check (< (xlib:drawable-x (window discord)) 700) "Discord is on left in X") + (check (>= (xlib:drawable-x (window browser)) 700) "browser is on right in X") + (check (= (xlib:window-id (window discord)) (xlib:window-id (xlib:input-focus client))) + "keyboard focus is on incoming window") + (click-activity "right" "chat") + (check (eq chat (current "right")) "bar click uses same portable behavior") + (check (eq work (current "left")) "bar click swaps back") + (check (equal "right" (lime.x11:x11-backend-focused-head-id backend)) "clicked monitor retains command focus") + (check (null (lime.x11::x11-backend-ui-session backend)) "no unnecessary collision menu") + (dotimes (i 12) + (tap-activity (if (evenp i) "left" "right") "chat") + (check (lime.core:validate-world (world)) "repeated swaps preserve model"))) + (lime.x11:backend-select-head backend "right") + (lime.x11:backend-start-activity backend "other" "Other") + (let ((other (current "right"))) + (tap-activity "left" "chat") + (check (eq other (current "right")) "inactive return leaves other monitor alone") + (check (eq chat (current "left")) "inactive arrangement follows target monitor")) + (lime.x11:backend-extend-activity-to-head backend "chat" "right") + (check (eq chat (current "left")) "extension leaves original portion alone") + (check (null (lime.core:presentation-client-ids (current "right"))) "new portion does not gather windows") + (check (eq :extended (lime.x11:backend-activity-navigation-mode backend "chat")) "explicit extended mode") + (tap-activity "right" "other") (tap-activity "right" "chat") + (check (null (lime.core:presentation-client-ids (current "right"))) "extended empty portion intentionally resumes") + (check (eq chat (current "left")) "extended returns do not pull the other portion") + (tap-activity "right" "other") + (lime.x11:backend-select-head backend "left") + (lime.x11:backend-make-activity-portable backend "chat" "left") + (check (eq :portable (lime.x11:backend-activity-navigation-mode backend "chat")) "explicit return to portability") + (check (not (visible hidden)) "fold does not show hidden window") + ;; Leave an intentionally empty extended activity for restart. + (lime.x11:backend-extend-activity-to-head backend "other" "right") + (lime.x11:backend-save-session backend) + (let ((before (lime.x11::%session-snapshot backend))) + (check (= 3 (getf before :version)) "versioned footprint persistence") + (check (lime.x11::%validate-session-envelope before) "saved envelope validates")) + (lime.x11:stop-backend backend) (setf backend nil) + (start) (pump) + (check (not (getf (lime.x11:backend-session-status backend) :blocked-p)) "restart restore succeeds") + (check (eq :portable (lime.x11:backend-activity-navigation-mode backend "chat")) "portable state survives restart") + (check (eq :extended (lime.x11:backend-activity-navigation-mode backend "other")) "empty extended intent survives restart") + (check (not (visible hidden)) "hidden window remains hidden after restart") + (tap-activity "right" "chat") + (check (equal "chat" (lime.core:presentation-activity-id (current "right"))) "portable key works after restart") + (check (visible discord) "surviving application reconnected and moved") + (check (null (lime.x11::x11-backend-last-command-error backend)) "no command errors") + (check (lime.core:validate-world (world)) "final invariants") + (format t "~&Portable Activities smoke: ~D checks passed.~%" checks)))))) + (when backend (ignore-errors (lime.x11:stop-backend backend))) + (when client (ignore-errors (xlib:close-display client :abort t))) + (when server (uiop:terminate-process server) (uiop:wait-process server))))) + +(handler-case (run-portable-activity-smoke) + (error (c) (format *error-output* "~&Portable Activities smoke failed: ~A~%" c) (uiop:quit 1))) diff --git a/test/x11-resilience-smoke.lisp b/test/x11-resilience-smoke.lisp new file mode 100644 index 0000000..127dbd4 --- /dev/null +++ b/test/x11-resilience-smoke.lisp @@ -0,0 +1,301 @@ +;;;; Fault injection against an owned Xvfb and a real supervised developer loop. +;;;; Does not connect to the user's DISPLAY, REPL, or application processes. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/dev") + +(handler-case + (let* ((directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) (uiop:run-program '("mktemp" "-d" "/tmp/lime-resilience-XXXXXX") + :output :string)))) + (log-path (merge-pathnames "fault.log" directory)) + (server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (session nil) (supervisor nil) (client-display nil) (checks 0) + (supervisor-error nil) + (original-configure (symbol-function 'lime.x11::%handle-configure-request)) + (original-adopt (symbol-function 'lime.x11::icccm-adopt-client)) + (original-shutdown-bars (symbol-function 'lime.x11::shutdown-head-bars)) + (cleanup-count 0) + (original-start (symbol-function 'lime.x11:start-lime))) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number)) + (port-socket (usocket:socket-listen "127.0.0.1" 0 :reuse-address t)) + (port (usocket:get-local-port port-socket))) + (usocket:socket-close port-socket) + (setf client-display (xlib:open-default-display display-name)) + (let* ((root (xlib:screen-root (xlib:display-default-screen client-display))) + (windows (loop repeat 2 collect (xlib:create-window :parent root :x 0 :y 0 + :width 100 :height 100))) + (original-world nil) (view-id "keep-this")) + (labels ((check (truth label) + (assert truth () "Resilience: ~A" label) (incf checks)) + (await (predicate label) + (loop repeat 500 when (funcall predicate) return t + do (sleep 0.01) + finally + (error "Timed out: ~A (supervisor: ~A; running: ~S; paused: ~S; event: ~S; fault: ~S)" + label supervisor-error + (and session (lime.dev::development-session-running-p session)) + (and session (paused)) + (and session (lime.x11::x11-backend-event-context + (lime.dev:development-session-backend session))) + (and session (lime.dev::development-session-event-loop-condition session))))) + (owner (function) + (lime.dev:call-in-development-session function :session session)) + (paused () (lime.dev::development-session-paused-p session)) + (status () (lime.dev:development-status session)) + (repl-alive () + (let ((socket (usocket:socket-connect "127.0.0.1" port :timeout 1))) + (usocket:socket-close socket) t)) + (client-exists (window) + (find (xlib:window-id window) (xlib:query-tree root) :key #'xlib:window-id)) + (new-window () + (let ((window (xlib:create-window :parent root :x 0 :y 0 :width 80 :height 80))) + (xlib:display-finish-output client-display) window)) + (request-configure () + (setf (xlib:drawable-width (first windows)) 321) + (xlib:display-finish-output client-display)) + (inject-failure () + (setf (symbol-function 'lime.x11::%handle-configure-request) + (lambda (&rest args) (declare (ignore args)) + (error "Injected configure failure"))) + (request-configure) + (await #'paused "fault pauses event handling"))) + (dolist (window windows) (xlib:map-window window)) + (xlib:display-finish-output client-display) + (setf supervisor + (bt:make-thread + (lambda () + (handler-case + (lime.dev:run-development-session + :display-name display-name :head-discovery :none :session-file nil + :event-timeout 0.01 :diagnostic-file log-path :repl-port port) + (error (condition) (setf supervisor-error condition)))) + :name "Owned resilience supervisor")) + (await (lambda () lime.dev:*development-session*) "session startup") + (setf session lime.dev:*development-session*) + ;; Slynk installs debugger hooks; batch test failures must still + ;; exit nonzero rather than falling into an EOF-driven REPL. + #+sbcl (sb-ext:disable-debugger) + (check (repl-alive) "private Slynk endpoint available") + (owner (lambda (backend) + (setf original-world (lime.x11:x11-backend-world backend)) + (lime.x11:backend-save-view backend view-id "Keep this") + (lime.x11:backend-activate-view backend view-id))) + ;; BadWindow may arrive BEFORE DestroyNotify has retired the client. + (let ((window (new-window))) + (owner (lambda (backend) + (let* ((display (lime.x11::x11-backend-display backend)) + (managed (xlib::lookup-window display (xlib:window-id window)))) + (lime.x11:manage-window backend managed) + (xlib:display-finish-output display) + (xlib:destroy-window window) + (xlib:display-finish-output client-display) + (setf (xlib:drawable-x managed) 17) + (xlib:display-finish-output display)))) + (check (not (paused)) "async destroyed-client configure is harmless")) + ;; A query on a vanished, unregistered client must unwind, not hang. + (let ((window (new-window))) + (xlib:destroy-window window) + (xlib:display-finish-output client-display) + (let ((before (lime.x11::x11-backend-expected-x-error-count + (lime.dev:development-session-backend session)))) + (owner (lambda (backend) + (let ((display (lime.x11::x11-backend-display backend))) + (xlib:queue-event display :map-request :append-p t + :parent (lime.x11::x11-backend-root backend) + :window (xlib::lookup-window display (xlib:window-id window)))))) + (await (lambda () (> (lime.x11::x11-backend-expected-x-error-count + (lime.dev:development-session-backend session)) before)) + "stale MapRequest processed")) + (check (not (paused)) "stale MapRequest survives synchronous BadWindow")) + ;; Mid-adoption death: registered in the adapter, not yet in the core. + (let ((window (new-window)) (destroyed-p nil)) + (setf (symbol-function 'lime.x11::icccm-adopt-client) + (lambda (backend client-id managed) + (when (= (xlib:window-id managed) (xlib:window-id window)) + (xlib:destroy-window window) + (xlib:display-finish-output client-display) + (setf destroyed-p t)) + (funcall original-adopt backend client-id managed))) + (xlib:map-window window) + (xlib:display-finish-output client-display) + ;; Do not concurrently query the client connection while the + ;; injected owner-thread hook is using that same CLX display. + (await (lambda () destroyed-p) "adoption victim gone") + (owner (lambda (backend) + (check (lime.core:validate-world (lime.x11:x11-backend-world backend)) + "partial adoption does not corrupt core"))) + (setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt) + (check (not (paused)) "mid-adoption death is harmless")) + ;; Focus of an existing but unmapped window produces real BadMatch. + (let ((window (new-window))) + (owner (lambda (backend) + (let ((display (lime.x11::x11-backend-display backend))) + (xlib:set-input-focus display (xlib::lookup-window display (xlib:window-id window)) + :pointer-root) + (xlib:display-finish-output display)))) + (xlib:destroy-window window) + (xlib:display-finish-output client-display) + (check (not (paused)) "unviewable focus is harmless")) + (check (>= (getf (getf (getf (status) :backend-status) :diagnostics) :expected-x-errors) 4) + "expected races are counted") + ;; Root ownership conflicts must remain fatal to the attempted WM. + (check (handler-case + (progn (lime.x11:start-backend :display-name display-name :head-discovery :none) nil) + (xlib:access-error () t)) + "second WM cannot silently claim root") + (check (not (paused)) "original WM unaffected by second WM") + ;; Leave active grabs installed, then fail a real event handler. + (owner (lambda (backend) + (let ((wm-root (lime.x11::x11-backend-root backend))) + (check (eq :success (xlib:grab-keyboard wm-root)) "test keyboard grab") + (check (eq :success (xlib:grab-pointer wm-root '(:button-press :button-release))) + "test pointer grab") + (xlib:display-finish-output (lime.x11::x11-backend-display backend))))) + (inject-failure) + (let* ((snapshot (status)) + (report (getf snapshot :last-error-report))) + (check (getf snapshot :running-p) "control session remains running") + (check (getf snapshot :event-thread-alive-p) "owner thread services paused mailbox") + (check (eq :configure-request (getf (getf report :event) :kind)) "diagnostic has event context") + (check (search "Injected configure failure" (getf report :message)) "diagnostic has original failure") + (check (search "%DISPATCH-NEXT-EVENT" (getf report :backtrace)) "backtrace captured before unwind") + (check (probe-file log-path) "fault diagnostic written") + (check (search "Injected configure failure" (uiop:read-file-string log-path)) "fault survives in log") + (check (string= "600" (string-trim '(#\Newline) + (uiop:run-program (list "stat" "-c" "%a" (namestring log-path)) + :output :string))) "log is private") + (check (bt:thread-alive-p supervisor) "supervisor did not exit after event fault") + (check (repl-alive) "Slynk still accepts connections")) + (check (eq :success (xlib:grab-keyboard root)) "fault released keyboard grab") + (xlib:ungrab-keyboard client-display) + (check (eq :success (xlib:grab-pointer root '(:button-press))) "fault released pointer grab") + (xlib:ungrab-pointer client-display) + (xlib:display-finish-output client-display) + (check (every #'client-exists windows) "application windows survive pause") + ;; Deliberately invalid model: recovery must refuse, not reset it. + (let ((presentation nil) (old-focus nil)) + (owner (lambda (backend) + (setf presentation (lime.core:current-presentation + (lime.x11:x11-backend-world backend) + (lime.x11:x11-backend-focused-head-id backend)) + old-focus (lime.core:presentation-focus-client-id presentation) + (lime.core:presentation-focus-client-id presentation) "missing-client"))) + (check (handler-case (progn (lime.dev:resume-development-session session) nil) + (error () t)) "invalid model blocks resume") + (check (paused) "failed resume stays paused") + (owner (lambda (backend) (declare (ignore backend)) + (setf (lime.core:presentation-focus-client-id presentation) old-focus)))) + ;; A core-valid but partially lost adapter mapping is not safe either. + (let ((id nil) (managed nil)) + (owner (lambda (backend) + (setf id (lime.x11::%backend-client-id backend (first windows)) + managed (gethash id (lime.x11::x11-backend-client-windows backend))) + (remhash id (lime.x11::x11-backend-client-windows backend)))) + (check (handler-case (progn (lime.dev:resume-development-session session) nil) + (error () t)) "inconsistent adapter registration blocks resume") + (check (paused) "adapter validation failure stays paused") + (owner (lambda (backend) + (setf (gethash id (lime.x11::x11-backend-client-windows backend)) managed)))) + (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure) + (lime.dev:resume-development-session session) + (check (not (paused)) "explicit resume succeeds after repair") + (owner (lambda (backend) + (check (eq original-world (lime.x11:x11-backend-world backend)) "resume keeps same world") + (check (lime.core:find-view original-world view-id) "resume keeps saved checkpoint") + (check (lime.core:validate-world original-world) "resumed world valid"))) + ;; A surviving client whose adoption was interrupted can be finished + ;; deliberately on resume, without replaying unrelated events. + (let ((window (new-window))) + (setf (symbol-function 'lime.x11::icccm-adopt-client) + (lambda (backend id managed) + (funcall original-adopt backend id managed) + (when (= (xlib:window-id managed) (xlib:window-id window)) + (error "Injected partial adoption failure")))) + (xlib:map-window window) + (xlib:display-finish-output client-display) + (await #'paused "interrupted live adoption pauses") + (setf (symbol-function 'lime.x11::icccm-adopt-client) original-adopt) + (lime.dev:resume-development-session session) + (owner (lambda (backend) + (check (lime.core:find-client original-world + (lime.x11::%backend-client-id backend window)) + "resume finishes the interrupted adoption") + (check (lime.x11::%validate-client-registrations backend) + "repaired adoption has consistent registrations"))) + (xlib:destroy-window window) + (xlib:display-finish-output client-display) + (await (lambda () (owner (lambda (backend) + (null (lime.x11::%backend-client-id backend window))))) + "recovered client retires normally")) + ;; Logging itself must never cause the session to exit. + (owner (lambda (backend) (declare (ignore backend)) + (setf (lime.dev::development-session-diagnostic-file session) + (merge-pathnames "fault.log/impossible" directory)))) + (inject-failure) + (check (getf (status) :diagnostic-write-error) "log write failure remains inspectable") + (check (repl-alive) "failed log write does not take down control server") + (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure) + (owner (lambda (backend) (declare (ignore backend)) + (setf (lime.dev::development-session-diagnostic-file session) log-path))) + (lime.dev:resume-development-session session) + ;; A slow failing restart lasts longer than the xinit supervisor poll. + (setf (symbol-function 'lime.x11:start-lime) + (lambda (&rest args) (declare (ignore args)) + (sleep 1.2) (error "Injected restart failure"))) + (check (handler-case (progn (lime.dev:restart-development-session session) nil) + (error () t)) "restart failure is reported to caller") + (check (bt:thread-alive-p supervisor) "slow failed restart retains xinit supervisor") + (check (paused) "failed restart leaves paused control session") + (check (repl-alive) "failed restart retains same Slynk endpoint") + (check (every #'client-exists windows) "applications survive failed restart") + (setf (symbol-function 'lime.x11:start-lime) original-start) + (lime.dev:restart-development-session session) + (check (not (paused)) "explicit retry can restart") + (check (repl-alive) "successful restart retains Slynk") + (owner (lambda (backend) + (check (not (eq original-world (lime.x11:x11-backend-world backend))) + "restart honestly makes a new world") + (check (= 2 (hash-table-count (lime.x11::x11-backend-client-windows backend))) + "restart readopts surviving clients"))) + ;; A deliberate quit still exits the supervisor, even while paused. + (inject-failure) + ;; A failed UI cleanup must not skip client restoration or CLX close. + (setf (symbol-function 'lime.x11::shutdown-head-bars) + (lambda (backend) (declare (ignore backend)) + (incf cleanup-count) + ;; Let the supervisor notice quit while a second caller + ;; is already stopping. Cleanup must not run concurrently. + (sleep 1.2) + (error "Injected bar cleanup failure"))) + (owner #'lime.x11:backend-request-quit) + (lime.dev:stop-development-session session) + (await (lambda () (not (bt:thread-alive-p supervisor))) "intentional quit exits supervisor") + (bt:join-thread supervisor) + (check (null supervisor-error) "supervisor returned normally") + (check (null lime.dev:*development-session*) "intentional quit clears current session") + (check (every #'client-exists windows) "graceful stop did not destroy client windows") + (check (= 1 cleanup-count) "concurrent explicit/supervised stop cleans up only once") + (check (null (lime.x11::x11-backend-display (lime.dev:development-session-backend session))) + "failed bar cleanup still closes CLX") + (check (find :cleanup (getf (lime.x11:backend-diagnostics + (lime.dev:development-session-backend session)) :reports) + :key (lambda (report) (getf report :source))) + "cleanup failure retained in diagnostics") + (format t "~&Live X11 resilience: ~D checks passed. Diagnostics: ~A~%" checks directory)))) + (setf (symbol-function 'lime.x11::%handle-configure-request) original-configure + (symbol-function 'lime.x11::icccm-adopt-client) original-adopt + (symbol-function 'lime.x11::shutdown-head-bars) original-shutdown-bars + (symbol-function 'lime.x11:start-lime) original-start) + (when lime.dev:*development-session* (lime.dev:stop-development-session)) + (when supervisor (bt:join-thread supervisor)) + (when client-display (xlib:close-display client-display)) + (uiop:terminate-process server) + (uiop:wait-process server))) + (error (condition) + (format *error-output* "~&Resilience smoke failed: ~A~%" condition) + (uiop:quit 1))) diff --git a/test/x11-session-settings-smoke.lisp b/test/x11-session-settings-smoke.lisp new file mode 100644 index 0000000..8264766 --- /dev/null +++ b/test/x11-session-settings-smoke.lisp @@ -0,0 +1,177 @@ +;;;; Real XSETTINGS clients, Xresources, configuration rollback, and ownership. +;;;; Own Xvfb only; requires Python 3 with PyGObject/GTK 3 for the client probe. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(defun run-cursor-session-smoke () + (let ((server nil) (probe nil) (client nil) (backend nil) (checks 0)) + (unwind-protect + (progn + (setf server (uiop:launch-program + '("Xvfb" "-displayfd" "1" "-screen" "0" "800x600x24" + "-screen" "1" "640x480x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (name (format nil ":~D" number)) + (original (format nil "! Keep my resources~%Xft.dpi: 96~%Xcursor.theme: Adwaita~%Xcursor.size: 20~%Other.value: original~%")) + (config (lime.x11:make-lime-configuration + :cursor (lime.x11:make-ui-cursor-style :theme "Bibata-Original-Ice" :size 24))) + (environment-theme (uiop:getenv "XCURSOR_THEME")) + (environment-size (uiop:getenv "XCURSOR_SIZE"))) + (setf client (xlib:open-default-display name)) + (let* ((root (xlib:screen-root (xlib:display-default-screen client))) + (other-root (xlib:screen-root (second (xlib:display-roots client)))) + (baseline nil)) + (labels ((check (truth label) + (assert truth () "Cursor session: ~A" label) (incf checks)) + (sync () (xlib:display-finish-output client)) + (resources () (lime.x11::%read-session-resources root)) + (owner () (xlib:selection-owner client :_XSETTINGS_S0)) + (state () (gethash backend lime.x11::*cursor-session-settings*)) + (start-probe () + (setf probe (uiop:launch-program + (list "env" "GDK_BACKEND=x11" "GTK_USE_PORTAL=0" + (format nil "DISPLAY=~A" name) + "python3" "test/gtk-cursor-probe.py") + :input :stream :output :stream :error-output :interactive)) + (uiop:split-string (read-line (uiop:process-info-output probe)) :separator "|")) + (query () + (write-line "query" (uiop:process-info-input probe)) + (finish-output (uiop:process-info-input probe)) + (uiop:split-string (read-line (uiop:process-info-output probe)) :separator "|")) + (expect-gtk (theme size) + (let ((answer (loop repeat 50 for answer = (query) + when (and (equal theme (first answer)) + (equal (princ-to-string size) (second answer))) + return answer))) + (check answer (format nil "GTK sees ~A / ~A (now ~S)" theme size (unless answer (query)))) + (check (equal (cddr answer) (cddr baseline)) "GTK font/icon/application theme unchanged"))) + (apply-style (theme size) + (let ((next (lime.x11::copy-lime-configuration config))) + (setf (lime.x11:lime-configuration-cursor next) + (lime.x11:make-ui-cursor-style :theme theme :size size)) + (lime.x11:apply-lime-configuration backend next))) + (pump () + (loop repeat 200 while (lime.x11::%dispatch-next-event backend 0)))) + (lime.x11::%write-session-resources root original) + (sync) + ;; The GTK process predates the manager: exercise MANAGER discovery. + (setf baseline (start-probe)) + (setf backend (lime.x11:start-backend :display-name name :head-discovery :none + :install-default-keybindings-p nil)) + (check (null (owner)) "no implicit settings manager with system defaults") + (xlib:send-event root :client-message '(:substructure-notify) + :window root :type :_LIME_CURSOR_TEST :format 32 :data #(0 0 0 0 0)) + (sync) + (lime.x11:apply-lime-configuration backend config) + (check (xlib:event-case ((lime.x11::x11-backend-display backend) :timeout 0 :discard-p nil) + (:client-message (type) (eq type :_LIME_CURSOR_TEST))) + "timestamp acquisition preserves unrelated queued events") + (check (owner) "manager selection acquired") + (check (zerop (hash-table-count (lime.core::world-clients (lime.x11:x11-backend-world backend)))) + "settings window is not a managed client") + (check (search "Xcursor.theme: Bibata-Original-Ice" (resources)) "theme resource") + (check (search "Xcursor.size: 24" (resources)) "size resource") + (check (search "Other.value: original" (resources)) "unrelated resources preserved") + (check (null (xlib:get-property other-root :RESOURCE_MANAGER)) "other X screen resources untouched") + (check (null (xlib:selection-owner client :_XSETTINGS_S1)) "other X screen selection untouched") + (expect-gtk "Bibata-Original-Ice" 24) + (check (equal "Bibata-Original-Ice|24" + (string-trim '(#\Newline) + (uiop:run-program + (list "env" "-u" "XCURSOR_THEME" "-u" "XCURSOR_SIZE" + (format nil "DISPLAY=~A" name) "python3" "-c" + "import ctypes as c; x=c.CDLL('libX11.so.6'); u=c.CDLL('libXcursor.so.1'); x.XOpenDisplay.restype=c.c_void_p; d=x.XOpenDisplay(None); u.XcursorGetTheme.argtypes=[c.c_void_p]; u.XcursorGetTheme.restype=c.c_char_p; u.XcursorGetDefaultSize.argtypes=[c.c_void_p]; print(u.XcursorGetTheme(d).decode()+'|'+str(u.XcursorGetDefaultSize(d))); x.XCloseDisplay.argtypes=[c.c_void_p]; x.XCloseDisplay(d)") + :output :string))) "new non-GTK Xcursor client reads session resources") + (multiple-value-bind (data type format) (xlib:get-property (owner) :_XSETTINGS_SETTINGS) + (check (eq type :_XSETTINGS_SETTINGS) "settings property type") + (check (= format 8) "settings property format") + (check (equalp (coerce data 'vector) (lime.x11::%xsettings-cursor-bytes "Bibata-Original-Ice" 24 1)) + "independent client reads complete initial publication")) + (let ((first-owner (owner))) + (apply-style "Bibata-Original-Classic" 32) + (check (xlib:window-equal first-owner (owner)) "reload keeps selection window stable") + (expect-gtk "Bibata-Original-Classic" 32)) + ;; A child sees the cursor environment; the WM process does not. + (let ((output (uiop:run-program + (lime.x11::%cursor-session-launch-argv + backend '("python3" "-c" "import os; print(os.environ['XCURSOR_THEME']); print(os.environ['XCURSOR_SIZE'])")) + :output :string))) + (check (equal output (format nil "Bibata-Original-Classic~%32~%")) "real child inherits configured cursor settings") + (check (equal environment-theme (uiop:getenv "XCURSOR_THEME")) "parent theme environment unchanged") + (check (equal environment-size (uiop:getenv "XCURSOR_SIZE")) "parent size environment unchanged")) + ;; New settings are visible to hooks, but failing hooks roll back. + (let ((bad (lime.x11::copy-lime-configuration config)) (caught nil)) + (setf (lime.x11:lime-configuration-startup-hooks bad) + (list (lambda (backend) + (check (equal "Bibata-Original-Ice" + (lime.x11::cursor-session-settings-theme + (gethash backend lime.x11::*cursor-session-settings*))) + "startup hook sees new settings") + (error "Rollback fixture")))) + (handler-case (lime.x11:apply-lime-configuration backend bad :run-startup-hooks-p t) + (error () (setf caught t))) + (check caught "failed config reported") + (expect-gtk "Bibata-Original-Classic" 32) + (check (search "Xcursor.size: 32" (resources)) "failed config resources rolled back")) + ;; Returning to defaults must not read Lime's own last theme. + (apply-style nil nil) + (check (null (owner)) "system defaults release manager") + (check (equal original (resources)) "exact original resource bytes restored") + ;; GTK 3 caches a removed XSETTING in GtkSettings even though + ;; GDK removes it. A fresh process must use its own defaults. + (uiop:terminate-process probe) (uiop:wait-process probe) + (check (equal baseline (start-probe)) "new GTK client returns to its own defaults") + (check (equal (getf (lime.x11:backend-cursor-report backend) :theme) + (or environment-theme "Adwaita")) "NIL theme avoids publication feedback") + (apply-style nil 48) + (expect-gtk (first baseline) 48) + (check (search "Xcursor.theme: Adwaita" (resources)) "size-only config retains original theme resource") + (apply-style :core 32) + (check (null (owner)) "core mode does not impose core on applications") + (check (equal original (resources)) "core mode restores resources") + ;; Never steal a manager started before us or taking over later. + (let ((external (xlib:create-window :parent root :x -1 :y -1 :width 1 :height 1))) + (unwind-protect + (progn + (setf (xlib:selection-owner client :_XSETTINGS_S0) external) + (sync) + (apply-style "Bibata-Original-Ice" 24) + (check (xlib:window-equal external (owner)) "existing manager never stolen") + (check (eq :external-manager (lime.x11::cursor-session-settings-manager-status (state))) + "existing manager is reported") + (setf (xlib:selection-owner client :_XSETTINGS_S0) nil) + (sync) + (apply-style "Bibata-Original-Ice" 24) + (let ((old-window (lime.x11::cursor-session-settings-window (state)))) + (setf (xlib:selection-owner client :_XSETTINGS_S0) external) + (sync) + (pump) + (check (null (lime.x11::cursor-session-settings-window (state))) "SelectionClear destroys our manager") + (check (xlib:window-equal external (owner)) "takeover is respected") + (check (not (member (xlib:window-id old-window) + (mapcar #'xlib:window-id (xlib:query-tree root)))) + "retired manager window actually destroyed"))) + (xlib:destroy-window external) (sync))) + ;; External xrdb edits must not be lost at shutdown. + (apply-style "Bibata-Original-Ice" 24) + (lime.x11::%write-session-resources + root (lime.x11::%replace-cursor-resource + (concatenate 'string (resources) (format nil "Other.added: later~%")) + "Xcursor.size" (list (format nil "Xcursor.size: 64~%")))) + (sync) + (lime.x11:stop-backend backend :save-session-p nil) + (check (null (owner)) "shutdown releases selection") + (check (search "Other.added: later" (resources)) "external unrelated edit retained") + (check (search "Xcursor.size: 64" (resources)) "externally replaced cursor size retained") + (check (search "Xcursor.theme: Adwaita" (resources)) "still-owned theme restored") + (check (null (gethash backend lime.x11::*cursor-session-settings*)) "shutdown forgets backend state") + (format t "~&Live X11 cursor session: ~D checks passed.~%" checks))))) + (when backend (lime.x11:stop-backend backend :save-session-p nil)) + (when probe (uiop:terminate-process probe) (uiop:wait-process probe)) + (when client (xlib:close-display client :abort t)) + (when server (uiop:terminate-process server) (uiop:wait-process server))))) + +(handler-case (run-cursor-session-smoke) + (error (condition) (format *error-output* "~&Cursor session smoke failed: ~A~%" condition) (uiop:quit 1))) diff --git a/test/x11-session-settings.lisp b/test/x11-session-settings.lisp new file mode 100644 index 0000000..f17c5f2 --- /dev/null +++ b/test/x11-session-settings.lisp @@ -0,0 +1,50 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(test cursor-resource-edits-preserve-unrelated-records + (let* ((original (format nil "! comment~%Xft.dpi: 96~% Xcursor.theme : Adwaita~%st.value: foo\\~%Xcursor.size: not-a-resource~%last: no newline")) + (next (lime.x11::%replace-cursor-resource original "Xcursor.theme" + (list (format nil "Xcursor.theme: Bibata~%")))) + (state (lime.x11::make-cursor-session-settings + :resources-before original :resources-last next :resources-owned-p t))) + (is (= 5 (length (lime.x11::%cursor-resource-records original)))) + (is (null (lime.x11::%cursor-resource-entries original "Xcursor.size"))) + (is (search (format nil "st.value: foo\\~%Xcursor.size: not-a-resource~%") next)) + (is (equal original (lime.x11::%unpublished-cursor-resources state next))) + (let ((external (concatenate 'string next (format nil "Other.setting: changed~%")))) + (is (search "Other.setting: changed" (lime.x11::%unpublished-cursor-resources state external))) + (is (equal (lime.x11::%cursor-resource-entries original "Xcursor.theme") + (lime.x11::%cursor-resource-entries + (lime.x11::%unpublished-cursor-resources state external) "Xcursor.theme")))) + (let ((external (lime.x11::%replace-cursor-resource next "Xcursor.theme" + (list (format nil "Xcursor.theme: Other~%"))))) + (is (equal external (lime.x11::%unpublished-cursor-resources state external)))) + (is (equal "" (lime.x11::%replace-cursor-resource nil "Xcursor.theme" nil))) + (is (null (lime.x11::%unpublished-cursor-resources + (lime.x11::make-cursor-session-settings :resources-before nil :resources-last next + :resources-owned-p t) next))))) + +(test cursor-settings-wire-encoding + (let ((bytes (lime.x11::%xsettings-cursor-bytes "Ice" 24 #x12345678))) + (is (equalp #(0 0 0 0 120 86 52 18 2 0 0 0 1 0 19 0) (subseq bytes 0 16))) + (is (equalp #(71 116 107 47 67 117 114 115 111 114 84 104 101 109 101 78 97 109 101 0) + (subseq bytes 16 36))) + (is (equalp #(120 86 52 18 3 0 0 0 73 99 101 0 0 0 19 0) (subseq bytes 36 52))) + (is (equalp #(120 86 52 18 24 0 0 0) (subseq bytes 72 80)))) + (is (= 12 (length (lime.x11::%xsettings-cursor-bytes nil nil 1)))) + (is (= 48 (length (lime.x11::%xsettings-cursor-bytes "氷" nil 1)))) + (dolist (bad (list (format nil "Ice~%Xft.dpi: 999") (format nil "Ice~C" #\Return))) + (signals invalid-transition + (lime.x11::%validate-ui-cursor-style (make-ui-cursor-style :theme bad))))) + +(test cursor-child-environment-is-an-argument-vector + (let* ((backend (lime.x11::%make-x11-backend)) + (argv '("program" "argument with spaces" "$no-shell-expansion"))) + (unwind-protect + (progn + (is (eq argv (lime.x11::%cursor-session-launch-argv backend argv))) + (setf (gethash backend lime.x11::*cursor-session-settings*) + (lime.x11::make-cursor-session-settings :theme "A theme" :size 32)) + (is (equal (append '("env" "XCURSOR_THEME=A theme" "XCURSOR_SIZE=32") argv) + (lime.x11::%cursor-session-launch-argv backend argv)))) + (remhash backend lime.x11::*cursor-session-settings*)))) diff --git a/test/x11-status-smoke.lisp b/test/x11-status-smoke.lisp new file mode 100644 index 0000000..e4351fd --- /dev/null +++ b/test/x11-status-smoke.lisp @@ -0,0 +1,191 @@ +;;;; Isolated X + fake MPD protocol peer. Never changes the user's audio/player. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") + +(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (checks 0) (listener nil) (peer nil) (peer-thread nil) + (peer-error nil) (gate (bt:make-lock)) (signal (bt:make-condition-variable)) + (phase 0) (allow-change nil) (requests 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (display-name (format nil ":~D" number))) + (labels ((check (truth label) (assert truth () "Status: ~A" label) (incf checks)) + (await (predicate &optional (seconds 3)) + (let ((deadline (+ (get-internal-real-time) (* seconds internal-time-units-per-second)))) + (loop until (funcall predicate) + do (when (> (get-internal-real-time) deadline) (error "Status test timed out: ~A" peer-error)) + (sleep 0.005)))) + (cached (id) + (getf (find id (lime.x11:backend-status-provider-report backend) + :key (lambda (entry) (getf entry :id))) :text)) + (snapshot (id) + (getf (find id (lime.x11:backend-status-provider-report backend) + :key (lambda (entry) (getf entry :id))) :value)) + (pump () + (xlib:event-case ((lime.x11::x11-backend-display backend) :timeout 1 :discard-p t) + (:client-message (window type) + (lime.x11::%handle-status-notification backend window type) t) + (otherwise () t)))) + (setf backend (lime.x11:start-lime :display-name display-name :head-discovery :none)) + (let ((revision (lime.core:world-revision (lime.x11:x11-backend-world backend)))) + ;; Fake MPD retains a change occurring between snapshot and idle. + (setf listener (usocket:socket-listen "127.0.0.1" 0 :reuse-address t :element-type '(unsigned-byte 8))) + (setf peer-thread + (bt:make-thread + (lambda () + (handler-case + (progn + (setf peer (usocket:socket-accept listener :element-type '(unsigned-byte 8))) + (let ((stream (usocket:socket-stream peer))) + (lime.x11::%mpd-send stream "OK MPD 0.24.0") + (loop for command = (lime.x11::%mpd-line stream) + do (incf requests) + (cond + ((string= command "status") + (lime.x11::%mpd-send stream (if (zerop phase) "state: play" "state: pause")) + (lime.x11::%mpd-send stream "OK")) + ((string= command "currentsong") + (lime.x11::%mpd-send stream "Title: 日本語 music") + (lime.x11::%mpd-send stream "OK")) + ((string= command "idle player playlist") + (bt:with-lock-held (gate) + (loop until allow-change do (bt:condition-wait signal gate)) + (setf allow-change nil)) + (incf phase) + (lime.x11::%mpd-send stream "changed: player") + (lime.x11::%mpd-send stream "OK")) + (t (error "Unexpected MPD request: ~A" command)))))) + (error (condition) (setf peer-error condition)))) :name "Fake MPD")) + (let* ((music (lime.x11:make-music-status-provider :mpd-port (usocket:get-local-port listener))) + (clock (lime.x11:make-clock-status-provider)) + (config (lime.x11:make-lime-configuration :status-providers (list music clock) + :status-providers-supplied-p t))) + (lime.x11:apply-lime-configuration backend config) + (await (lambda () (and (cached :music) (cached :clock)))) + (check (string= " 日本語 music" (cached :music)) "UTF-8 native MPD initial snapshot") + (check (equal '(:state :playing :title "日本語 music" :source :mpd) (snapshot :music)) "MPD publishes data, not icons") + (check (search "" (cached :clock)) "initial clock") + (check (= 2 (length (lime.x11::status-runtime-workers (lime.x11::x11-backend-status-runtime backend)))) "one worker per provider, not per Head") + (await (lambda () (>= requests 3))) + (let ((count requests)) + (sleep 0.08) + (check (= count requests) "idle causes zero repeat MPD queries")) + ;; Drain initial exposures and the initial coalesced publication. + (loop while (xlib:event-listen (lime.x11::x11-backend-display backend)) do (pump)) + (let ((runtime (lime.x11::x11-backend-status-runtime backend))) + (check (not (lime.x11::status-runtime-dirty-p runtime)) "initial notification consumed") + (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal)) + (let ((start (get-internal-real-time))) + ;; This waits for an actual X event, not a polling refresh. + (pump) + (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 0.75) + "publication wakes an idle X wait immediately")) + (check (string= " 日本語 music" (cached :music)) "pause event, no user input needed") + ;; Presentation changes consume the cache on the X thread; + ;; there is no new query, source restart, or source mutation. + (let* ((formatter (lime.x11:status-provider-formatter music)) + (workers (copy-list (lime.x11::status-runtime-workers runtime))) + (before (snapshot :music)) + (count requests)) + (unwind-protect + (progn + (setf (lime.x11:status-provider-formatter music) + (lambda (data) + (lime.x11:make-head-bar-segment + :text (format nil "Track: ~A" (getf data :title)) :foreground "#55aa66"))) + (lime.x11:apply-lime-configuration backend config) + (check (string= "Track: 日本語 music" (cached :music)) "configured label replaces default icons") + (check (equal before (snapshot :music)) "formatting leaves source data intact") + (check (equal workers (lime.x11::status-runtime-workers runtime)) "style reload keeps existing workers") + (check (= count requests) "style change does not query MPD") + (let* ((bar (gethash (first (lime.x11:backend-head-ids backend)) + (lime.x11::x11-backend-head-bars backend))) + (pixels (lime.x11::ui-canvas-pixels (lime.x11::x11-head-bar-canvas bar)))) + (check (loop for i below (array-total-size pixels) + thereis (= #x55aa66 (logand #xffffff (row-major-aref pixels i)))) + "custom widget color actually painted")) + (setf (lime.x11:status-provider-formatter music) + (lambda (data) (declare (ignore data)) (error "broken fixture formatter"))) + (lime.x11::render-head-bars backend) + (check (typep (lime.x11:backend-last-command-error backend) 'error) "formatter error isolated") + (check (cached :clock) "other widget survives formatter failure") + (check (equal before (snapshot :music)) "formatter failure preserves data") + (check (every (lambda (worker) (bt:thread-alive-p (lime.x11::status-worker-thread worker))) workers) + "formatter failure does not kill workers")) + (setf (lime.x11:status-provider-formatter music) formatter) + (lime.x11::render-head-bars backend))) + (let ((worker (find music (lime.x11::status-runtime-workers runtime) + :key #'lime.x11::status-worker-provider))) + (lime.x11:status-publish worker (snapshot :music)) + (check (not (lime.x11::status-runtime-dirty-p runtime)) "identical data does not enqueue a redraw") + (lime.x11:status-publish worker '(:state :paused :title "burst one" :source :mpd)) + (lime.x11:status-publish worker '(:state :paused :title "burst two" :source :mpd)) + (pump) + (check (string= " burst two" (cached :music)) "coalesced notification paints latest value")) + (check (= revision (lime.core:world-revision (lime.x11:x11-backend-world backend))) "status never changes model state") + (let ((workers (copy-list (lime.x11::status-runtime-workers runtime)))) + (lime.x11:apply-lime-configuration backend config) + (check (equal workers (lime.x11::status-runtime-workers runtime)) "same provider objects are not duplicated on reload")) + ;; Failed reload must restore old providers with live workers. + (handler-case + (lime.x11:apply-lime-configuration + backend (lime.x11:make-lime-configuration + :status-providers (list (lime.x11:make-clock-status-provider :id :replacement)) + :status-providers-supplied-p t + :startup-hooks (list (lambda (ignored) (declare (ignore ignored)) (error "test rollback")))) + :run-startup-hooks-p t) + (error ())) + (check (eq config (lime.x11:x11-backend-configuration backend)) "configuration rolled back") + (check (equal (sort (mapcar (lambda (entry) (getf entry :id)) (lime.x11:backend-status-provider-report backend)) + #'string< :key #'symbol-name) + '(:clock :music)) "old provider set restored") + ;; Stop while the clock sleeps and MPD is blocked in idle. + (let ((workers (copy-list (lime.x11::status-runtime-workers runtime))) + (start (get-internal-real-time))) + (lime.x11:backend-set-head-bar-status-providers backend nil) + (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 4) "bounded cancellation") + (check (every (lambda (worker) (not (bt:thread-alive-p (lime.x11::status-worker-thread worker)))) workers) "all removed workers joined") + (check (null (lime.x11::x11-backend-status-runtime backend)) "last removal closes notifier")))) + ;; A failed source is isolated and retries while other widgets run. + (let* ((attempts 0) + (failed (lime.x11:make-status-provider + :id :test-retry + :run (lambda (worker) + (incf attempts) + (if (= attempts 1) (error "fixture unavailable") + (progn (lime.x11:status-publish worker "reconnected") + (lime.x11:status-wait worker 60)))))) + (clock (lime.x11:make-clock-status-provider))) + (lime.x11:backend-set-head-bar-status-providers backend (list failed clock)) + (await (lambda () (and (cached :clock) (cached :test-retry)))) + (check (= 2 attempts) "source failure retries with backoff") + (check (string= "reconnected" (cached :test-retry)) "other providers survive failure")) + ;; A blocked subprocess is killed/reaped, not left after reload. + (let ((provider (lime.x11:make-status-provider + :id :blocked-helper + :run (lambda (worker) + (lime.x11::%call-with-status-process + worker '("sleep" "60") + (lambda (stream process) (declare (ignore process)) + (lime.x11::%status-read-line stream))))))) + (lime.x11:backend-set-head-bar-status-providers backend (list provider)) + (let* ((runtime (lime.x11::x11-backend-status-runtime backend)) + (worker (first (lime.x11::status-runtime-workers runtime)))) + (await (lambda () (bt:with-lock-held ((lime.x11::status-worker-lock worker)) + (lime.x11::status-worker-cancel-functions worker)))) + (let ((start (get-internal-real-time))) + (lime.x11:backend-set-head-bar-status-providers backend nil) + (check (< (/ (- (get-internal-real-time) start) internal-time-units-per-second) 1) + "blocked helper cancellation is immediate") + (check (not (bt:thread-alive-p (lime.x11::status-worker-thread worker))) "helper reader joined")))) + (format t "~&Status live-X smoke: ~D checks passed.~%" checks)))) + (when backend (lime.x11:stop-backend backend)) + (bt:with-lock-held (gate) (setf allow-change t) (bt:condition-notify signal)) + (when peer (ignore-errors (usocket:socket-shutdown peer :io))) + (when listener (ignore-errors (usocket:socket-close listener))) + (when peer-thread (bt:join-thread peer-thread)) + (when peer (ignore-errors (usocket:socket-close peer))) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11-status.lisp b/test/x11-status.lisp new file mode 100644 index 0000000..821e56b --- /dev/null +++ b/test/x11-status.lisp @@ -0,0 +1,235 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +(test status-formatters + (is (= 60 (lime.x11::%next-minute-delay 120))) + (is (= 1 (lime.x11::%next-minute-delay 179))) + (is (< (abs (- 0.25d0 (lime.x11::%next-minute-delay 179.75d0))) 0.00001)) + (let ((data (lime.x11::%clock-snapshot (encode-universal-time 59 7 15 30 9 2026)))) + (is (= 15 (getf data :hour))) + (is (= 2026 (getf data :year))) + (is (string= " Wed Sep 30, 03:07" (lime.x11:format-clock-status data))) + (is (string= " Wed Sep 30, 15:07" (lime.x11:format-clock-status data :twenty-four-hour-p t)))) + (is (string= " Wed Sep 30, 12:00" + (lime.x11:format-clock-status (lime.x11::%clock-snapshot (encode-universal-time 0 0 0 30 9 2026))))) + (is (= 25 (lime.x11::%volume-percent "Volume: front-left: 16384 / 25% / -36.12 dB, front-right: 16384 / 25%"))) + (is (= 150 (lime.x11::%volume-percent "mono: 98304 / 150% / 1.23 dB"))) + (signals error (lime.x11::%volume-percent "no sink")) + (is (lime.x11::%volume-event-p "Event 'change' on sink #42")) + (is (lime.x11::%volume-event-p "Event 'change' on server #0")) + (is (lime.x11::%volume-event-p "Event 'remove' on card #1")) + (is (not (lime.x11::%volume-event-p "Event 'new' on client #9"))) + (is (not (lime.x11::%volume-event-p "Event 'change' on sink-input #9"))) + (is (equal '(:state :playing :title "スパイダー" :source :mpd) + (lime.x11::%music-snapshot "play" "スパイダー" :mpd))) + (is (string= " スパイダー" (lime.x11:format-music-status (lime.x11::%music-snapshot "play" "スパイダー" :mpd)))) + (let ((data (lime.x11::%mpris-line-snapshot (format nil "Paused~Chello" #\Tab) "spotify"))) + (is (eq :paused (getf data :state))) + (is (equal "spotify" (getf data :source))) + (is (string= " hello" (lime.x11:format-music-status data)))) + (is (null (lime.x11::%mpris-line-snapshot "" "spotify"))) + (let ((data (lime.x11::%music-snapshot "stop" "old track" :mpd))) + (is (equal "old track" (getf data :title))) + (is (eq :stopped (getf data :state))) + (is (null (lime.x11:format-music-status data)))) + (is (string= " Untitled track" (lime.x11:format-music-status (lime.x11::%music-snapshot "play" "" :mpd)))) + (is (string= " 25%" (lime.x11:format-volume-status '(:volume 25 :muted-p nil)))) + (is (string= " Muted" (lime.x11:format-volume-status '(:volume 25 :muted-p t)))) + (is (string= "\"a\\\"b\\\\c\"" (lime.x11::%mpd-quote "a\"b\\c"))) + (signals error (lime.x11::%mpd-quote (format nil "foo~%bar")))) + +(test status-icons-and-gaps-are-presentation-options + (let ((font (lime.x11::%open-text-font + (lime.x11:make-ui-font-style + :family "Dina, Fira Code Nerd Font, Noto Color Emoji" :size 12 :weight :bold)))) + (unwind-protect + (dolist (pair '(("" "Song") ("" "スパイダー") ("" "25%") + ("" "Muted") ("" "Wed Sep 30, 03:07"))) + (destructuring-bind (icon label) pair + (let ((text (lime.x11::%status-icon-label icon label " "))) + (is (string= text (concatenate 'string icon " " label))) + (is (> (lime.x11::%text-width font text) + (lime.x11::%text-width font (concatenate 'string icon " " label))))))) + (lime.x11::%free-text-font font))) + (is (string= "PLAY · My track" + (lime.x11:format-music-status '(:state :playing :title "My track") + :playing-icon "PLAY" :icon-gap " · "))) + (is (string= "Quiet" (lime.x11:format-volume-status '(:muted-p t :volume 30) + :muted-icon nil :muted-label "Quiet")))) + +(test status-icon-colors-preserve-text-and-provider-behavior + (let* ((click (lambda (&rest ignored) (declare (ignore ignored)))) + (provider (make-volume-status-provider + :foreground "#dbc9a6" :maximum-width 100 :click-action click + :formatter (lambda (data) + (format-volume-status data :icon-foreground "#76929f")))) + (segment (lime.x11::%format-status-segment provider '(:volume 25)))) + (is (string= " 25%" (head-bar-segment-text segment))) + (is (string= "#dbc9a6" (head-bar-segment-foreground segment))) + (is (string= "#76929f" (head-bar-segment-prefix-foreground segment))) + (is (= 1 (head-bar-segment-prefix-length segment))) + (is (= 100 (head-bar-segment-maximum-width segment))) + (is (eq click (head-bar-segment-click-action segment)))) + (dolist (segment (list (format-music-status '(:state :paused :title "スパイダー") + :paused-icon "PAUSE" :icon-foreground "#76929f") + (format-volume-status '(:muted-p t) :icon-foreground "#76929f") + (format-clock-status (lime.x11::%clock-snapshot (get-universal-time)) + :icon-foreground "#76929f"))) + (is (typep segment 'head-bar-segment)) + (is (string= "#76929f" (head-bar-segment-prefix-foreground segment))) + (is (null (head-bar-segment-foreground segment)))) + (is (string= "25%" (format-volume-status '(:volume 25) :icon nil :icon-foreground "#76929f"))) + (is (null (format-music-status '(:state :stopped) :icon-foreground "#76929f"))) + (signals invalid-transition (format-volume-status '(:volume 25) :icon-foreground "blue")) + (dolist (bad '(-1 99 1/2 nil)) + (signals invalid-transition + (lime.x11::%validate-head-bar-segment (make-head-bar-segment :text "test" :prefix-length bad))))) + +(test status-provider-validation + (let ((provider (lime.x11:make-clock-status-provider))) + (is (equal (list provider) (lime.x11::%validate-status-providers (list provider)))) + (is (lime.x11::%validate-status-providers (list provider (lambda (backend head) (declare (ignore backend head)))))) + (signals lime.core:invalid-transition + (lime.x11::%validate-status-providers (list provider (lime.x11:make-clock-status-provider))))) + (signals lime.core:invalid-transition + (lime.x11::%validate-status-providers (list (lime.x11:make-status-provider :id :broken)))) + (signals error (lime.x11:make-music-status-provider :source :unknown)) + (signals error (lime.x11:make-music-status-provider :maximum-width 0)) + (signals invalid-transition + (lime.x11::%validate-status-providers (list (lime.x11:make-clock-status-provider :formatter nil)))) + (signals invalid-transition + (lime.x11::%validate-status-providers (list (lime.x11:make-volume-status-provider :foreground "red")))) + (is (typep (lime.x11:make-music-status-provider :source "brave" :sources '("brave")) 'lime.x11:status-provider))) + +(test status-data-is-snapshotted-and-formatted-only-by-the-consumer + (let* ((calls 0) + (runtime (lime.x11::make-status-runtime :closed-p t)) + (input (list :state :playing :title (copy-seq "Original"))) + (provider (lime.x11:make-music-status-provider + :formatter (lambda (data) + (incf calls) + ;; Even a mutating formatter cannot damage the cache. + (setf (char (getf data :title) 0) #\X) + (getf data :title)))) + (worker (lime.x11::make-status-worker :runtime runtime :provider provider))) + (let ((returned (lime.x11:status-publish worker input))) + (setf (char (getf returned :title) 0) #\Y)) + (setf (getf input :state) :paused (char (getf input :title) 0) #\Z) + (is (zerop calls)) + (is (equal '(:state :playing :title "Original") (lime.x11::%status-worker-snapshot worker))) + (let ((segment (lime.x11::%format-status-segment provider (lime.x11::%status-worker-snapshot worker)))) + (is (= 1 calls)) + (is (string= "Xriginal" (head-bar-segment-text segment))) + (is (equal '(:state :playing :title "Original") (lime.x11::%status-worker-snapshot worker)))) + ;; NIL means unavailable, not a formatting callback with incomplete data. + (is (null (lime.x11::%format-status-segment provider nil))) + (is (= 1 calls)))) + +(test status-formatters-can-return-colored-segments-or-hide-data + (let* ((click (lambda (backend head) (declare (ignore backend head)))) + (provider (lime.x11:make-volume-status-provider :foreground "#aabbcc" :maximum-width 90 :click-action click)) + (value '(:volume 25 :muted-p nil :sink "fixture"))) + (let ((segment (lime.x11::%format-status-segment provider value))) + (is (eq :volume (head-bar-segment-id segment))) + (is (equal "#aabbcc" (lime.x11:head-bar-segment-foreground segment))) + (is (= 90 (head-bar-segment-maximum-width segment))) + (is (eq click (head-bar-segment-click-action segment)))) + (setf (lime.x11:status-provider-formatter provider) + (lambda (data) (make-head-bar-segment :text (format nil "Volume ~D" (getf data :volume)) + :foreground "#112233" :maximum-width 40))) + (let ((segment (lime.x11::%format-status-segment provider value))) + (is (string= "Volume 25" (head-bar-segment-text segment))) + (is (equal "#112233" (lime.x11:head-bar-segment-foreground segment))) + (is (= 40 (head-bar-segment-maximum-width segment))) + (is (eq click (head-bar-segment-click-action segment)))) + (setf (lime.x11:status-provider-formatter provider) (constantly nil)) + (is (null (lime.x11::%format-status-segment provider value))) + (setf (lime.x11:status-provider-formatter provider) + (lambda (data) (declare (ignore data)) (make-head-bar-segment :text "bad" :foreground "not a color"))) + (signals invalid-transition (lime.x11::%format-status-segment provider value)))) + +(test custom-status-formatting-can-show-stopped-music-and-differing-date-styles + (let* ((music (lime.x11:make-music-status-provider + :formatter (lambda (data) (format nil "~(~A~): ~A" (getf data :state) (getf data :title))))) + (clock (lime.x11:make-clock-status-provider + :formatter (lambda (data) (format nil "~D-~2,'0D-~2,'0D" (getf data :year) + (getf data :month) (getf data :day)))))) + (is (string= "stopped: Track" + (head-bar-segment-text (lime.x11::%format-status-segment music + (lime.x11::%music-snapshot "stop" "Track" :mpd))))) + (is (string= "2026-09-30" + (head-bar-segment-text (lime.x11::%format-status-segment clock + (lime.x11::%clock-snapshot (encode-universal-time 0 0 0 30 9 2026)))))))) + +(test status-publication-and-cancellation + (let* ((runtime (lime.x11::make-status-runtime :closed-p t)) + (worker (lime.x11::make-status-worker :runtime runtime))) + (lime.x11:status-publish worker "first") + (is (string= "first" (lime.x11::status-worker-value worker))) + (lime.x11:status-publish worker nil) + (is (null (lime.x11::status-worker-value worker))) + (lime.x11::%stop-status-worker worker) + (lime.x11:status-publish worker "late result") + (is (null (lime.x11::status-worker-value worker))) + (is (not (lime.x11:status-wait worker 60))) + (let ((cancelled nil) (ran nil)) + (lime.x11::%call-with-status-resource worker (lambda () (setf cancelled t)) + (lambda () (setf ran t))) + (is (eq t cancelled)) + (is (not ran))))) + +(test volume-subscription-coalesces-bursts-without-polling + (let* ((worker (lime.x11::make-status-worker :runtime (lime.x11::make-status-runtime :closed-p t))) + (snapshots 0) + (events (format nil "Event 'new' on client #1~%Event 'change' on sink #2~%Event 'change' on sink #2~%Event 'change' on server #0~%"))) + (signals error ; finite fixture EOF is a normal source disconnect + (lime.x11::%run-volume-status + worker + :subscribe (lambda (ignored argv action) + (declare (ignore ignored)) + (is (equal '("pactl" "subscribe") argv)) + (with-input-from-string (stream events) (funcall action stream nil))) + :snapshot (lambda (ignored) (declare (ignore ignored)) (format nil "snapshot ~D" (incf snapshots))))) + (is (= 2 snapshots)) ; initial + one burst, not 3 events or an interval + (is (string= "snapshot 2" (lime.x11::status-worker-value worker))))) + +(test widget-width-cap-keeps-following-widgets-and-graphemes + (let ((font (lime.x11::%open-text-font (lime.x11:make-ui-font-style)))) + (unwind-protect + (let* ((music (lime.x11:make-head-bar-segment :id :music :text "👩‍💻👩‍💻👩‍💻 a long track" + :maximum-width 65)) + (clock (lime.x11:make-head-bar-segment :id :clock :text "12:34")) + (runs (nth-value 3 (lime.x11::%fit-bar-status font (list music clock) 500))) + (first (first runs))) + (is (eq music (getf first :segment))) + (is (<= (getf first :width) 65)) + (is (find (getf first :prefix) + (lime.x11::text-metrics-boundaries + (lime.x11::%text-metrics font (lime.x11:head-bar-segment-text music))))) + (is (eq clock (getf (car (last runs)) :segment)))) + (lime.x11::%free-text-font font)))) + +(test music-source-switching-and-command-routing + (let* ((provider (lime.x11:make-music-status-provider :mpd-host "localhost" :mpd-port 6601)) + (runtime (lime.x11::make-status-runtime :closed-p t)) + (backend (lime.x11::%make-x11-backend :status-runtime runtime :head-bar-status-providers (list provider))) + (old-worker nil)) + ;; Exercise the real lifecycle with a test source, never actual playback. + (setf (lime.x11::status-provider-run provider) + (lambda (worker) (lime.x11:status-wait worker 60)) + old-worker (lime.x11::%start-status-worker runtime provider) + (lime.x11::status-runtime-workers runtime) (list old-worker)) + (unwind-protect + (progn + (is (equal '("mpc" "--host" "localhost" "--port" "6601" "prev") + (lime.x11::%music-command-argv provider :previous))) + (is (equal "spotify" (lime.x11:backend-cycle-music-source backend))) + (is (not (bt:thread-alive-p (lime.x11::status-worker-thread old-worker)))) + (is (= 1 (length (lime.x11::status-runtime-workers runtime)))) + (is (equal '("playerctl" "--player" "spotify" "play-pause") + (lime.x11::%music-command-argv provider :toggle))) + (is (equal '("playerctl" "--player" "spotify" "previous") + (lime.x11::%music-command-argv provider :previous))) + (is (eq :mpd (lime.x11:backend-cycle-music-source backend))) + (signals error (lime.x11::%music-command-argv provider :invalid))) + (mapc #'lime.x11::%stop-status-worker (lime.x11::status-runtime-workers runtime))))) diff --git a/test/x11-text.lisp b/test/x11-text.lisp new file mode 100644 index 0000000..f793324 --- /dev/null +++ b/test/x11-text.lisp @@ -0,0 +1,195 @@ +(in-package #:lime.x11.test) +(in-suite lime-x11-suite) + +;; Pango/Cairo measurements are headless: these tests do not open DISPLAY. +(lime.config:defconfiguration font-config-fixture + (:font :family "sans-serif, monospace" :size 18 :weight :bold)) + +(test font-configuration-is-shared-and-validated + (let ((font (lime-configuration-font font-config-fixture))) + (is (string= "sans-serif, monospace" (ui-font-style-family font))) + (is (= 18 (ui-font-style-size font))) + (is (eq :bold (ui-font-style-weight font))) + (is (eq font-config-fixture (lime.x11::%validate-lime-configuration font-config-fixture)))) + (dolist (style (list (make-ui-font-style :family " ") + (make-ui-font-style :family (format nil "bad~%family")) + (make-ui-font-style :size 0) + (make-ui-font-style :size 97) + (make-ui-font-style :size "14") + (make-ui-font-style :weight :unknown))) + (signals invalid-transition (lime.x11::%validate-ui-font-style style))) + (signals error + (macroexpand-1 '(lime.config:defconfiguration bad-font (:font) (:font)))) + (signals error + (macroexpand-1 '(lime.config:defconfiguration bad-font (:font :typo 10))))) + +(test shaped-text-fits-without-splitting-graphemes + (let ((font (lime.x11::%open-text-font (make-ui-font-style :family "sans-serif")))) + (unwind-protect + (progn + (is (> (lime.x11::%text-width font "WWW") (lime.x11::%text-width font "iii"))) + (is (= 0 (lime.x11::%text-width font ""))) + (dolist (text '("é" "👩‍💻" "🇲🇽")) + (is (equalp (vector 0 (length text)) + (lime.x11::text-metrics-boundaries (lime.x11::%text-metrics font text))))) + (dolist (text '("ééé café" "👩‍💻 👩‍💻 long title" "🇲🇽🇲🇽 日本語" "مرحبا بالعالم")) + (let* ((metrics (lime.x11::%text-metrics font text)) + (boundaries (lime.x11::text-metrics-boundaries metrics))) + ;; Check every pixel budget, not one lucky truncation boundary. + (is (loop for width from 0 to (lime.x11::text-metrics-width metrics) + always + (multiple-value-bind (fitted prefix) (lime.x11::%fit-ui-text font text width) + (and (<= (lime.x11::%text-width font fitted) width) + (find prefix boundaries) + (string= text fitted :end1 prefix :end2 prefix))))))) + (dotimes (i 300) (lime.x11::%text-width font (format nil "cache ~D" i))) + (is (<= (hash-table-count (lime.x11::ui-text-font-metrics font)) 256))) + (lime.x11::%free-text-font font)) + (is-false (lime.x11::ui-text-font-layout font)) + (is-false (lime.x11::ui-canvas-surface (lime.x11::ui-text-font-canvas font))) + (lime.x11::%free-text-font font))) + +(test absent-font-family-falls-back-and-font-resources-replace-safely + (let* ((style (make-ui-font-style :family "Lime Deliberately Nonexistent Font")) + (font (lime.x11::%open-text-font style)) + (new nil)) + (unwind-protect + (progn + (is (= 0 (lime.x11::text-metrics-unknown-glyphs (lime.x11::%text-metrics font "Hello")))) + (is (eq font (lime.x11::%ensure-text-font font style))) + (signals invalid-transition + (lime.x11::%ensure-text-font font (make-ui-font-style :size 0))) + (is-true (lime.x11::ui-text-font-layout font)) + (setf new (lime.x11::%ensure-text-font font (make-ui-font-style :size 28))) + (is-false (lime.x11::ui-text-font-layout font)) + (is (> (lime.x11::%font-line-height new) 28))) + (lime.x11::%free-text-font font) + (lime.x11::%free-text-font new)))) + +(test status-shaping-keeps-widget-boundaries-and-rtl-click-ranges + (let ((font (lime.x11::%open-text-font (make-ui-font-style)))) + (unwind-protect + (progn + (multiple-value-bind (text prefix width runs) + (lime.x11::%fit-bar-status + font (list (make-head-bar-segment :text "مرحبا") + (make-head-bar-segment :text "🎮")) 300) + (declare (ignore text prefix)) + (is (= 3 (length runs))) + (is (equal '("مرحبا" " | " "🎮") (mapcar (lambda (run) (getf run :text)) runs))) + (is (= width (reduce #'+ runs :key (lambda (run) (getf run :width)))))) + (let* ((text "مرحبا...") + (ranges (lime.x11::%text-prefix-ranges font text 5))) + (is-true ranges) + ;; For this RTL run the logical suffix dots are visually at left. + (is (plusp (caar ranges))) + (is (every (lambda (range) (<= 0 (car range) (cdr range) + (lime.x11::%text-width font text))) ranges)))) + (lime.x11::%free-text-font font)))) + +(test prefix-color-rasterization-keeps-unicode-shaping-and-resets-between-fields + (let ((font (lime.x11::%open-text-font (make-ui-font-style))) + (canvas (lime.x11::%make-ui-canvas 300 28))) + (unwind-protect + (labels ((pixels () + (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas)) + (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas))) + (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas)))) + (loop for y below 28 append + (loop for x below 300 collect + (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4)))))))) + (red-p (pixel) (and (plusp pixel) (zerop (logand pixel #xffff)))) + (gray-p (pixel) (= (ldb (byte 8 16) pixel) (ldb (byte 8 8) pixel) (ldb (byte 8 0) pixel)))) + (dolist (text '("A title" "é 日本語" "é مرحبا")) + (let ((width (lime.x11::%text-width font text)) (normal nil)) + (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000") + (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff") + (setf normal (pixels)) + (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000") + (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff" + :prefix-length 1 :prefix-color "#ff0000") + (let ((colored (pixels))) + (is (some #'red-p colored)) + (is (some (lambda (p) (and (plusp p) (gray-p p))) colored)) + ;; Foreground attributes must not move glyphs or change coverage. + (is (equal (mapcar (lambda (p) (ldb (byte 8 16) p)) normal) + (mapcar (lambda (p) (ldb (byte 8 16) p)) colored)))) + (is (= width (lime.x11::%text-width font text))) + (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000") + (lime.x11::%canvas-text canvas font text 0 0 300 28 "#ffffff") + (is (equal normal (pixels))))) + ;; With no retained source characters, truncation dots stay neutral. + (multiple-value-bind (ignored prefix width runs) + (lime.x11::%fit-bar-status font (list (make-head-bar-segment :text "Long icon and label" + :prefix-length 4 :prefix-foreground "#ff0000")) + (lime.x11::%text-width font "...")) + (declare (ignore ignored prefix width)) + (let ((run (first runs))) + (is (= 0 (getf run :prefix))) + (lime.x11::%canvas-rectangle canvas 0 0 300 28 "#000000") + (lime.x11::%canvas-text canvas font (getf run :text) 0 0 300 28 "#ffffff" + :prefix-length (getf run :prefix) :prefix-color "#ff0000") + (is (every #'gray-p (pixels)))))) + (lime.x11::%free-ui-canvas canvas) + (lime.x11::%free-text-font font)))) + +(test opaque-rgb-upload-respects-truecolor-masks + (is (= #xf800 (lime.x11::%rgb-to-visual-pixel #xff0000 #xf800 #x7e0 #x1f 16))) + (is (= #xffff (lime.x11::%rgb-to-visual-pixel #xffffff #xf800 #x7e0 #x1f 16))) + (is (= #x563412 (lime.x11::%rgb-to-visual-pixel #x123456 #xff #xff00 #xff0000 24))) + (is (= #x3fffffff (lime.x11::%rgb-to-visual-pixel #xffffff #x3ff00000 #xffc00 #x3ff 30))) + (is (= #xff123456 (lime.x11::%rgb-to-visual-pixel #x123456 #xff0000 #xff00 #xff 32)))) + +(test measured-palette-rows-keep-selection-visible + (is (equal '(0 8) (multiple-value-list (lime.x11::%ui-visible-range 20 0 8)))) + (is (equal '(5 13) (multiple-value-list (lime.x11::%ui-visible-range 20 12 8)))) + (is (equal '(12 20) (multiple-value-list (lime.x11::%ui-visible-range 20 19 8)))) + (is (equal '(0 2) (multiple-value-list (lime.x11::%ui-visible-range 2 1 8)))) + (is (equal '(0 0) (multiple-value-list (lime.x11::%ui-visible-range 0 0 0))))) + +(defun text-test-ink-bounds (canvas) + "Bounds of nonblack pixels, for checking real rasterization rather than math alone." + (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas)) + (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas))) + (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas))) + (left (lime.x11::ui-canvas-width canvas)) (right 0) + (top (lime.x11::ui-canvas-height canvas)) (bottom 0)) + (dotimes (y (lime.x11::ui-canvas-height canvas)) + (dotimes (x (lime.x11::ui-canvas-width canvas)) + (when (plusp (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4))))) + (setf left (min left x) right (max right (1+ x)) + top (min top y) bottom (max bottom (1+ y)))))) + (values left top right bottom))) + +(test bar-baseline-centers-letter-bodies-not-empty-font-leading + (dolist (style (list (make-ui-font-style) + (make-ui-font-style :family "Dina, Fira Code Nerd Font" :size 12 :weight :bold))) + (let ((font (lime.x11::%open-text-font style)) + (canvas (lime.x11::%make-ui-canvas 240 22))) + (unwind-protect + (let ((baseline (lime.x11::%font-centered-baseline font 22))) + (lime.x11::%canvas-rectangle canvas 0 0 240 22 "#000000") + (lime.x11::%canvas-text canvas font "ABCabc012" 10 0 220 22 "#ffffff" :baseline baseline) + (multiple-value-bind (left top right bottom) (text-test-ink-bounds canvas) + (is (<= 10 left right 230)) + (is (<= (abs (- top (- 22 bottom))) 1)) + (is (< 0 top bottom 22))) + ;; A descender changes ink bounds, but must not move existing letters. + (let ((old-pixels nil) + (sample-width (lime.x11::%text-width font "ABCabc012"))) + (labels ((sample-pixels () + (lime.x11::%cairo-flush (lime.x11::ui-canvas-surface canvas)) + (let ((data (lime.x11::%cairo-data (lime.x11::ui-canvas-surface canvas))) + (stride (lime.x11::%cairo-stride (lime.x11::ui-canvas-surface canvas)))) + (loop for y below 22 append + (loop for x from 10 below (+ 10 sample-width) collect + (logand #xffffff (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4))))))))) + (setf old-pixels (sample-pixels)) + (lime.x11::%canvas-rectangle canvas 0 0 240 22 "#000000") + (lime.x11::%canvas-text canvas font "ABCabc012 gj" 10 0 220 22 "#ffffff" :baseline baseline) + (is (equal old-pixels (sample-pixels))))) + ;; Fallback glyphs and other measurements don't alter the reference. + (lime.x11::%text-metrics font "日本語 🎮 Égj") + (is (= baseline (lime.x11::%font-centered-baseline font 22)))) + (lime.x11::%free-ui-canvas canvas) + (lime.x11::%free-text-font font))))) diff --git a/test/x11-ui-smoke.lisp b/test/x11-ui-smoke.lisp new file mode 100644 index 0000000..59ada64 --- /dev/null +++ b/test/x11-ui-smoke.lisp @@ -0,0 +1,169 @@ +;;;; Real-X command-map checks. Own Xvfb server, never the current DISPLAY. +;;;; Optionally bind *UI-SMOKE-IMAGE-DIRECTORY* before loading to save PNGs. +(require :asdf) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(defvar *ui-smoke-image-directory* nil) + +(let ((server (uiop:launch-program '("Xvfb" "-displayfd" "1" "-screen" "0" "1000x622x24" "-nolisten" "tcp") + :output :stream :error-output :interactive)) + (backend nil) (checks 0)) + (unwind-protect + (let* ((number (parse-integer (read-line (uiop:process-info-output server)))) + (config (lime.x11:make-lime-configuration + :default-keybindings-p nil + :font (lime.x11:make-ui-font-style + :family "Dina, Fira Code Nerd Font, Noto Color Emoji" :size 12 :weight :bold) + :bar-style (lime.x11:make-head-bar-style + :background "#191919" :foreground "#d8c9ad" + :focused-background "#252525" :focused-foreground "#c49a62" + :separator-color "#8c9b7a" :title-edge-color "#444444")))) + (setf backend (lime.x11:start-lime :display-name (format nil ":~D" number) :head-discovery :none)) + (lime.x11:apply-lime-configuration backend config) + (let* ((display (lime.x11::x11-backend-display backend)) + (world (lime.x11:x11-backend-world backend)) + (revision (lime.core:world-revision world))) + (labels ((check (truth label) (assert truth () "Command menu: ~A" label) (incf checks)) + (session () (lime.x11::x11-backend-ui-session backend)) + (overlay () (lime.x11::x11-backend-ui-overlay backend)) + (press (key) + (let* ((keysym (if (characterp key) (char-code key) key)) + (code (xlib:keysym->keycodes display keysym))) + (check code (format nil "keycode for ~S" key)) + (lime.x11::%handle-ui-key-press backend code 0) + (xlib:display-finish-output display))) + (frame (&optional name) + (let* ((overlay (overlay)) + (canvas (lime.x11::x11-ui-overlay-canvas overlay)) + (window (lime.x11::x11-ui-overlay-window overlay))) + (xlib:display-finish-output display) + (check (equalp (lime.x11::ui-canvas-pixels canvas) + (xlib:image-z-pixarray + (xlib:get-image window :x 0 :y 0 + :width (lime.x11::ui-canvas-width canvas) + :height (lime.x11::ui-canvas-height canvas) + :format :z-pixmap))) "actual painted frame") + (when (and name *ui-smoke-image-directory*) + (check (zerop (lime.x11::%cairo-write-png + (lime.x11::ui-canvas-surface canvas) + (namestring (merge-pathnames name *ui-smoke-image-directory*)))) + "snapshot"))))) + (lime.x11:backend-open-command-palette backend) + (check (eq :key-path (lime.ui:ui-session-mode (session))) "Super-y starts at the key root") + (check (< (lime.x11::x11-ui-overlay-height (overlay)) 200) "root is compact") + (frame "menu-root.png") + (press #\w) + (check (string= "Lime › w Windows" (lime.x11::%ui-menu-heading (session))) "breadcrumb") + (frame "menu-windows.png") + (press #xFF08) ; Backspace + (check (null (lime.ui:ui-session-key-path (session))) "Backspace returns to root") + (press #\Space) + (check (eq :search (lime.ui:ui-session-mode (session))) "Space opens search") + (press #\v) + (check (string= "v" (lime.ui:ui-session-query (session))) "search types rather than navigates") + (frame "menu-search.png") + (press #xFF09) ; Tab + (check (eq :key-path (lime.ui:ui-session-mode (session))) "Tab returns to root") + (check (= revision (lime.core:world-revision world)) "browsing does not change the model") + (press #\v) + (press #\s) + (check (eq :prompt (lime.ui:ui-session-mode (session))) "v s is a name prompt") + (check (string= "Enter to confirm; Esc to cancel." (lime.ui:ui-session-status (session))) + "prompt footer describes prompt keys, not menu keys") + (frame "menu-prompt.png") + (dolist (key '(#\c #\o #\d #\e #\Space #\v #\i #\e #\w)) (press key)) + (press #xFF0D) + (check (not (lime.x11:backend-command-palette-open-p backend)) "successful command closes") + (check (getf (lime.x11:backend-status backend) :source-view-id) "checkpoint actually saved") + (lime.x11:backend-open-command-palette backend) + (press #\v) + (press #\o) + (check (eq :search (lime.ui:ui-session-mode (session))) "v o opens the View picker") + (check (every (lambda (candidate) (eq :view (first (lime.ui:ui-candidate-id candidate)))) + (lime.ui:ui-session-candidates (session))) "View picker is scoped") + (press #xFF09) + (press #\Space) + (check (find :quit-lime (lime.ui:ui-session-candidates (session)) :key #'lime.ui:ui-candidate-id) + "global search restored after a scoped picker") + (press #xFF1B) + (check (not (lime.x11:backend-command-palette-open-p backend)) "Escape closes") + ;; Explicit recall restores even the last-used checkpoint. It + ;; is intentionally different from reselecting a numbered slot. + (let* ((head-id (lime.x11:x11-backend-focused-head-id backend)) + (p (lime.core:current-presentation world head-id)) + (view-id (lime.core:presentation-source-view-id p)) + (saved-mode (lime.core:view-layout-mode (lime.core:find-view world view-id)))) + (lime.core:set-presentation-layout-mode world (lime.core:presentation-id p) :monocle) + (lime.x11:apply-active-presentation backend) + (lime.x11:backend-open-command-palette backend) + (press #\v) (press #\o) + (check (search "Recall view" (lime.ui:ui-candidate-label + (first (lime.ui:ui-session-candidates (session))))) + "saved arrangements use recall language") + (press #xFF0D) + (check (eq saved-mode (lime.core:presentation-layout-mode p)) "explicit recall restores saved layout") + (check (not (lime.core:presentation-dirty-p p)) "explicit recall clears live edits") + ;; Direct shortcut opens a picker; opening/choosing does not + ;; modify a checkpoint, and Enter defaults to Cancel. + (lime.core:set-presentation-layout-mode world (lime.core:presentation-id p) :monocle) + (lime.x11:apply-active-presentation backend) + (let ((before (lime.persistence:snapshot-world world))) + (lime.x11:backend-open-view-update-picker backend) + (frame) + (press #xFF0D) + (check (eq :cancel (lime.ui:ui-candidate-id + (lime.ui:ui-session-selected-candidate (session)))) "replacement defaults to cancel") + (frame) + (press #xFF0D) + (check (not (session)) "cancel closes picker") + (check (equalp before (lime.persistence:snapshot-world world)) "cancel preserves checkpoint and live desk")) + ;; Menu update uses the same picker and named confirmation. + (lime.x11:backend-open-command-palette backend) + (press #\v) (press #\u) (press #xFF0D) (press #xFF54) (press #xFF0D) + (check (not (session)) "confirmed replacement closes picker") + (check (eq :monocle (lime.core:view-layout-mode (lime.core:find-view world view-id))) "only confirmed update replaces checkpoint") + ;; A configured-command wrapper must not close its own picker. + (lime.x11:apply-lime-configuration + backend (lime.x11:make-lime-configuration + :default-keybindings-p nil + :commands (list (lime.x11:make-lime-command + :id :update :label "Update saved view" + :action #'lime.x11:backend-open-view-update-picker)))) + (lime.x11:backend-open-command-palette backend) + (press #\Space) + (let ((candidate (find '(:configured-command :update) + (lime.ui:ui-session-candidates (session)) + :key #'lime.ui:ui-candidate-id :test #'equal))) + (check candidate "configured command is available in search") + (lime.x11::%perform-ui-action backend (list :candidate candidate))) + (check (eq :search (lime.ui:ui-session-mode (session))) "configured update enters picker without closing") + (press #xFF1B)) + ;; Program launch remains the independent direct-search surface. + (lime.x11:backend-open-run-prompt backend) + (check (eq :search (lime.ui:ui-session-mode (session))) "Super-p still searches programs") + (check (null (lime.ui:ui-session-key-root (session))) "launcher has no command tree") + (press #xFF1B) + ;; Small Heads / large user maps page instead of dropping entries. + (let* ((head (gethash (first (lime.x11:backend-head-ids backend)) + (lime.x11::x11-backend-heads backend))) + (nodes (loop for i below 40 collect + (lime.ui:make-ui-key-node :key (code-char (+ 256 i)) + :label (format nil "Custom command ~D" i))))) + (setf (lime.x11:x11-head-width head) 320 (lime.x11:x11-head-height head) 260) + (lime.x11::%open-ui-session backend (lime.ui:make-ui-session nil :key-path nodes :mode :key-path)) + (check (<= (lime.x11::x11-ui-overlay-height (overlay)) 238) "bounded to small Head") + (press #xFF56) ; PageDown + (check (= 1 (lime.ui:ui-session-key-page (session))) "PageDown navigates grid") + (frame "menu-narrow.png") + (press #xFF55) + (check (= 0 (lime.ui:ui-session-key-page (session))) "PageUp navigates grid") + (setf (lime.ui:ui-session-key-page (session)) 999) + (lime.x11::%render-command-palette backend) + (check (< (lime.ui:ui-session-key-page (session)) 999) "last page clamps") + (press #xFF55) + (check (>= (lime.ui:ui-session-key-page (session)) 0) "paging back remains available") + (press #xFF1B)) + (format t "~&Live X11 command menu: ~D checks passed.~%" checks)))) + (when backend (lime.x11:stop-backend backend)) + (uiop:terminate-process server) + (uiop:wait-process server))) diff --git a/test/x11.lisp b/test/x11.lisp new file mode 100644 index 0000000..ddb9baa --- /dev/null +++ b/test/x11.lisp @@ -0,0 +1,1542 @@ +(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)) diff --git a/work/activity-workflow-proposal.html b/work/activity-workflow-proposal.html new file mode 100644 index 0000000..4084bc1 --- /dev/null +++ b/work/activity-workflow-proposal.html @@ -0,0 +1,104 @@ +
+ +
+ +
+
+
+
+
+
+
+ diff --git a/work/arrange-mode-concept.html b/work/arrange-mode-concept.html new file mode 100644 index 0000000..acb2e3f --- /dev/null +++ b/work/arrange-mode-concept.html @@ -0,0 +1,216 @@ +
+ +
+
LimeWM:Code · |M|ARRANGE
+
+
+
Click a window or type its label. Your applications stay visible.
+
+ +
diff --git a/work/bar-design-comparison.html b/work/bar-design-comparison.html new file mode 100644 index 0000000..fb878ad --- /dev/null +++ b/work/bar-design-comparison.html @@ -0,0 +1,163 @@ +
+ + +
+
A · Sectioned, left-alignedRecommendedFocused head
+ +
+ +
+
B · Sectioned, region-centeredFocused head
+ +
+ +
+
C · Minimal, head-centeredFocused head
+ +
+ + +
diff --git a/work/bar-grouping.html b/work/bar-grouping.html new file mode 100644 index 0000000..4044b7b --- /dev/null +++ b/work/bar-grouping.html @@ -0,0 +1,170 @@ +
+ + +
+
A · Refined grouping · Focused head
+ +
+ +
+
Same design · Unfocused head
+ +
+ + +
diff --git a/work/bar-title-edges.html b/work/bar-title-edges.html new file mode 100644 index 0000000..dacb08d --- /dev/null +++ b/work/bar-title-edges.html @@ -0,0 +1,170 @@ +
+ + + + +
+
1 · Background onlyMy pick
+ +
+ +
+
2 · Left accent · Current treatment
+ +
+ +
+
3 · Two subtle edges
+ +
+ + +
diff --git a/work/check-arrangement-migration.lisp b/work/check-arrangement-migration.lisp new file mode 100644 index 0000000..e2ffdeb --- /dev/null +++ b/work/check-arrangement-migration.lisp @@ -0,0 +1,43 @@ +;;;; Read a backup, migrate ONLY an isolated model, and exercise all Head/Activity pairs. +(require :asdf) +(asdf:initialize-output-translations + '(:output-translations ("/home/adan/code/common-lisp/lime/" "/tmp/lime-working-arrangements/fasl/") :inherit-configuration)) +(asdf:load-asd (truename (merge-pathnames "../lime.asd" *load-truename*))) +(asdf:load-system "lime/x11") +(let* ((*read-eval* nil) + (path (first (uiop:command-line-arguments))) + (data (with-open-file (stream path) (read stream))) + (before (getf data :world)) + (world (lime.x11::%validate-session-envelope data)) + (after (lime.persistence:snapshot-world world)) + (pairs 0)) + (dolist (key '(:clients :activities :views :viewsets :heads)) + (assert (equalp (getf before key) (getf after key)) () "Migration changed ~S." key)) + (dolist (h (getf before :heads)) + (let ((id (getf h :active))) + (assert (equalp (find id (getf before :presentations) :key (lambda (p) (getf p :id)) :test #'equal) + (find id (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal)) + () "Migration changed an active arrangement."))) + (lime.core:normalize-activity-arrangements world) + (assert (equalp after (lime.persistence:snapshot-world world))) + (dolist (h (getf after :heads)) + (dolist (a (getf after :activities)) + (let* ((copy (lime.persistence:restore-world after)) + (head (getf h :id)) + (others (loop for p being the hash-values of (lime.core::world-presentations copy) + when (and (lime.core:presentation-active-p copy p) + (not (equal head (lime.core:presentation-head-id p)))) + collect (list (lime.core:presentation-id p) + (lime.core:presentation-leased-client-ids copy p))))) + (assert (lime.core:activation-report-ready-p + (lime.core:preflight-activity-draft copy head (getf a :id)))) + (lime.core:open-activity-draft copy head (getf a :id)) + (dolist (row others) + (let ((p (lime.core:find-presentation copy (first row)))) + (assert (lime.core:presentation-active-p copy p)) + (assert (equal (second row) (lime.core:presentation-leased-client-ids copy p))))) + (lime.core:validate-world copy) + (incf pairs)))) + (format t "~&Migration copy verified: ~D clients, ~D saved views, ~D -> ~D live arrangements; ~D independent switches checked. Active arrangements unchanged.~%" + (length (getf after :clients)) (length (getf after :views)) + (length (getf before :presentations)) (length (getf after :presentations)) pairs)) diff --git a/work/lime-lisp-palettes.html b/work/lime-lisp-palettes.html new file mode 100644 index 0000000..16db8f1 --- /dev/null +++ b/work/lime-lisp-palettes.html @@ -0,0 +1,420 @@ +
+ +
+ + +
+
+
+
+ + + lime:Code* + + []= +
+ attention.lisp — Emacs +
! 1| quiet company| 32%| Thu Oct 01, 01:42
+
+
+
+
+
attention.lispconfig.lisp
+ 
;;; Attention belongs to the live session.
+
+(in-package #:lime.x11)
+
+(defun visit-next-request (backend)
+  (let ((requests
+          (backend-attention-client-ids backend)))
+    (when requests
+      (backend-attend-client backend
+                             (first requests)))))
+
+;; Quiet until something needs you.
+
+
+
+
** attention.lispLisp · 15:0
+
Connected to SBCL. Ready.
+
+
+
+
+

SBCL · lime development

+

LIME> (backend-attention-client-ids
*backend*)
("x11-800005")

+

LIME> (world-revision *world*)
42

+

LIME>

+
+
+
+
+ ~/notes/lime.org +

* Making a desk feel like home

+

DONE activities + views
DONE persistence
DONE attention indicators

+
+

NEXT actually live here

+
+
+
+
+
+
Lime
+
+ + + + + + +
+
Space · search commandsEsc · close
+
+
+
+ Your picks +
+
+ More colors +
+
+
+
+ +
diff --git a/work/lisp-workstation-study.html b/work/lisp-workstation-study.html new file mode 100644 index 0000000..1b6f6fb --- /dev/null +++ b/work/lisp-workstation-study.html @@ -0,0 +1,265 @@ + + +
+
+ + + + + []= + layout.lisp — Emacs + 15:42 +
+
+
+
+
+
lime / src / layout.lisp
+ 
;;; Arrangements are values.
+;;; The activity remains yours.
+
+(defun remember-arrangement (world head name)
+  (let ((draft (current-presentation world head)))
+    (save-view world draft name)))
+
+(defun return-to-code (world head)
+  (let ((view (find-view world "wm-project/code")))
+    (activate-view-strictly world head view)))
+
+;; Keep the work; change the perspective.
+
+
+
** layout.lispLisp · 8:5
+
+
+
+
+ 
~/code/lime › git status --short
+ M src/layout.lisp
+ M test/model.lisp
+
+master · 2 modified files
+
+~/code/lime ›
+
+
st · ~/code/limeshell
+
+
+
+

LIME.CORE> (current-presentation world head)

+ + +

; 248 checks passed.

+
LIME.CORE>
+
+
SLY · listenerSBCL · local
+
+
+
+ +
+
Concept study · Slate / celadon · Lime opens commands; the listener value is inspectable.
+
+ diff --git a/work/ui-layer-sketch.html b/work/ui-layer-sketch.html new file mode 100644 index 0000000..cd1697c --- /dev/null +++ b/work/ui-layer-sketch.html @@ -0,0 +1,191 @@ +
+ + +
+
Lime · development / Codeleft head · dirty
+ + + +
+ + +
diff --git a/work/upgrade-live-activity-bar.lisp b/work/upgrade-live-activity-bar.lisp new file mode 100644 index 0000000..8039a21 --- /dev/null +++ b/work/upgrade-live-activity-bar.lisp @@ -0,0 +1,83 @@ +;;;; Narrow UI-only hotload. No model migration or application operations. +(in-package #:cl-user) + +(defun lime-activity-bar-definitions () + (let ((manifest + '(("src/x11/bar.lisp" "%BAR-PRESENTATION-LABEL" "%BAR-ACTIVITY-ENTRIES") + ("src/x11/ui.lisp" "%UI-REQUEST-VIEW-ACTIVATION" "%UI-ACTIVITY-CANDIDATES" + "%UI-VIEW-UPDATE-CONTEXT-VALID-P" "%UI-CONFIRM-VIEW-UPDATE-RESULT" + "%UI-VIEW-UPDATE-PICKER-RESULT" "%UI-UPDATE-CURRENT-VIEW-CANDIDATE" + "%UI-COLLISION-CHOICE-CANDIDATES" + "%UI-KEY-PATH" "BACKEND-OPEN-VIEW-UPDATE-PICKER") + ("src/x11/default-bindings.lisp" "INSTALL-DEFAULT-KEYBINDINGS"))) + (definitions nil)) + (dolist (entry manifest) + (destructuring-bind (file &rest names) entry + (let* ((*package* (find-package :lime.x11)) (*read-eval* nil) + (symbols (mapcar (lambda (name) (intern name *package*)) names)) + (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-activity-bar () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (command (lime.x11:find-configured-command backend 'update-view)) + (old-label (lime.x11:lime-command-label command)) + (old-detail (lime.x11:lime-command-description command)) + (old-action (lime.x11:lime-command-action command)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (definitions (lime-activity-bar-definitions)) + (old-functions + (mapcar (lambda (form) + (let ((name (second form))) + (cons name (and (fboundp name) (fdefinition name))))) + definitions))) + (assert (equal "/home/adan/.config/lime/config.lisp" + (lime.x11::x11-backend-configuration-source backend))) + (assert (eq old-action (fdefinition 'lime.x11:backend-update-current-view))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + (export 'lime.x11::backend-open-view-update-picker :lime.x11) + ;; Bindings resolve the configured command by id at dispatch, so + ;; replacing these three fields needs no regrab/provider restart. + (setf (lime.x11:lime-command-label command) "Update saved view..." + (lime.x11:lime-command-description command) "Choose a saved arrangement to replace; confirm its name" + (lime.x11:lime-command-action command) + (fdefinition 'lime.x11::backend-open-view-update-picker)) + (lime.x11::render-head-bars backend) + (xlib:display-finish-output (lime.x11::x11-backend-display backend)) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :bindings-unchanged t + :function-count (length definitions) + :bars (loop for id in (lime.x11:backend-head-ids backend) + collect (list id (lime.x11::%bar-presentation-label backend id))) + :update-command (lime.x11:lime-command-label command))) + (error (condition) + (setf (lime.x11:lime-command-label command) old-label + (lime.x11:lime-command-description command) old-detail + (lime.x11:lime-command-action command) old-action) + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (ignore-errors (lime.x11::render-head-bars backend)) + (error condition)))))) diff --git a/work/upgrade-live-activity-order.lisp b/work/upgrade-live-activity-order.lisp new file mode 100644 index 0000000..49ce0e2 --- /dev/null +++ b/work/upgrade-live-activity-order.lisp @@ -0,0 +1,65 @@ +;;;; Function-only upgrade: Activity numbering changes, not the live world. +(in-package #:cl-user) + +(defun lime-activity-order-definitions () + (let* ((*package* (find-package :lime.x11)) (*read-eval* nil) + (names '(lime.x11::%navigation-activity-slots lime.x11::%navigation-state + lime.x11:backend-set-activity-slot lime.x11::%navigation-read-data)) + (found nil)) + (with-open-file (in #p"/home/adan/code/common-lisp/lime/src/x11/navigation.lisp") + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) names)) + do (push form found))) + (assert (= (length names) (length found))) + (mapcar (lambda (name) (or (find name found :key #'second) (error "Missing ~S" name))) names))) + +(defun lime-upgrade-live-activity-order (backup-path) + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((session (lime.x11::%session-snapshot backend)) + (world (lime.x11:x11-backend-world backend)) + (before (getf session :world)) + (before-nav (getf session :navigation)) + (state (lime.x11::%navigation-state backend)) + (old-state (lime.x11::copy-navigation-state state)) + (config (lime.x11::x11-backend-configuration backend)) + (definitions (lime-activity-order-definitions)) + (old-functions (mapcar (lambda (form) + (let ((name (second form))) + (cons name (and (fboundp name) (fdefinition name))))) definitions))) + (when (probe-file backup-path) (error "Refusing to overwrite the pre-upgrade backup.")) + (let ((store (lime.persistence:open-session-store backup-path))) + (unwind-protect (lime.persistence:write-session-store store session) + (lime.persistence:close-session-store store))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + ;; The existing cache already observed this model revision; force + ;; one metadata-only synchronization using the new slot policy. + (setf (lime.x11::navigation-state-observed-revision state) nil) + (let ((after-nav (lime.x11::%navigation-snapshot backend))) + (assert (equal (mapcar #'first (getf before-nav :activities)) + (mapcar #'first (getf after-nav :activities)))) + (assert (equal (loop for n from 1 to (length (getf after-nav :activities)) collect n) + (mapcar #'second (getf after-nav :activities)))) + (assert (equal (getf before-nav :views) (getf after-nav :views))) + (assert (equal (getf before-nav :resume) (getf after-nav :resume))) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (lime.x11::render-head-bars backend) + (xlib:display-finish-output (lime.x11::x11-backend-display backend)) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :views-unchanged t :bar-order-unchanged t + :activities (getf after-nav :activities) :backup backup-path))) + (error (condition) + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (setf (gethash backend lime.x11::*backend-navigation-states*) old-state) + (ignore-errors (lime.x11::render-head-bars backend)) + (error condition)))))) diff --git a/work/upgrade-live-arrangements.lisp b/work/upgrade-live-arrangements.lisp new file mode 100644 index 0000000..883a1f4 --- /dev/null +++ b/work/upgrade-live-arrangements.lisp @@ -0,0 +1,110 @@ +;;;; One-time, owner-thread upgrade. No structure changes or X window moves. +(in-package #:cl-user) + +(defun lime-upgrade-live-arrangements () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11::x11-backend-world backend)) + (session (lime.x11::%session-snapshot backend)) + (before (getf session :world)) + (nav (gethash backend lime.x11::*backend-navigation-states*)) + (old-nav (and nav (lime.x11::copy-navigation-state nav))) + (preferred (mapcar #'third (getf (getf session :navigation) :resume))) + (slots (lime.x11:backend-navigation-slots backend)) + (config (lime.x11::x11-backend-configuration backend)) + (revision (lime.core:world-revision world)) + (records (loop for p being the hash-values of (lime.core::world-presentations world) + collect (cons p (lime.core::copy-presentation p)))) + (manifest + '((:lime.core "src/operations.lisp" + "PREFLIGHT-PRESENTATION-RESUME" "ACTIVITY-DRAFT-FOR-HEAD" "PREFLIGHT-ACTIVITY-DRAFT" + "%TRANSFER-AWAY-FROM-INCUMBENT" "%REMOVE-LIVE-PLACEMENT" "%CLAIM-LIVE-LOCATIONS" + "COMMIT-ACTIVATION-PLAN" "OPEN-ACTIVITY-DRAFT" "TRANSFER-CLIENT-LEASE" + "RECLAIM-AVAILABLE-SLOTS" "SHOW-CLIENT-ON-PRESENTATION" + "NORMALIZE-ACTIVITY-ARRANGEMENTS" "VALIDATE-WORLD") + (:lime.core "src/membership.lisp" "MOVE-CLIENT-TO-ACTIVITY") + (:lime.core "src/viewset.lisp" "%INSTALL-VIEWSET-ENTRY") + (:lime.core "src/topology.lisp" "COMMIT-HEAD-TOPOLOGY-RECONCILIATION-PLAN") + (:lime.persistence "src/persistence/model.lisp" "SNAPSHOT-WORLD" "RESTORE-WORLD") + (:lime.x11 "src/x11/commands.lisp" "BACKEND-ACTIVATE-ACTIVITY" "BACKEND-ATTEND-CLIENT") + (:lime.x11 "src/x11/navigation.lisp" "%NAVIGATION-RESUME-TARGET") + (:lime.x11 "src/x11/ui.lisp" "%UI-REQUEST-ACTIVITY-ACTIVATION") + (:lime.x11 "src/x11/persistence.lisp" "%VALIDATE-SESSION-ENVELOPE" "%PREPARE-SESSION-PERSISTENCE"))) + (old-functions nil) (definitions nil) (migration nil)) + ;; An exact, current session backup using the normal private atomic writer. + (when (probe-file #p"/home/adan/.local/state/lime/pre-arrangements-Om1oWG/live-before.sexp") + (error "The pre-upgrade backup already exists; refusing to overwrite it.")) + (let ((store (lime.persistence:open-session-store + #p"/home/adan/.local/state/lime/pre-arrangements-Om1oWG/live-before.sexp"))) + (unwind-protect (lime.persistence:write-session-store store session) + (lime.persistence:close-session-store store))) + (export 'lime.core::normalize-activity-arrangements :lime.core) + (dolist (entry manifest) + (destructuring-bind (package file &rest names) entry + (let* ((*package* (find-package package)) (*read-eval* nil) + (symbols (mapcar (lambda (name) (intern name *package*)) names)) + (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (name symbols) + (assert (find name found :key #'second)) + (push (cons name (and (fboundp name) (fdefinition name))) old-functions)) + (setf definitions (append definitions (nreverse found)))))) + (handler-case + (progn + (dolist (form definitions) (eval form)) + ;; Recheck a fresh copy of this precise live state, not just the + ;; earlier disk backup. All tests below are read-only on the desk. + (let* ((candidate (lime.persistence:restore-world before :normalize-arrangements-p nil)) + (candidate-migration + (lime.core::normalize-activity-arrangements candidate :preferred-presentation-ids preferred)) + (after (lime.persistence:snapshot-world candidate))) + (dolist (key '(:clients :activities :views :viewsets :heads)) + (assert (equalp (getf before key) (getf after key)))) + (dolist (h (getf before :heads)) + (let ((id (getf h :active))) + (assert (equalp (find id (getf before :presentations) :key (lambda (p) (getf p :id)) :test #'equal) + (find id (getf after :presentations) :key (lambda (p) (getf p :id)) :test #'equal))))) + (dolist (h (getf after :heads)) + (dolist (a (getf after :activities)) + (assert (lime.core:activation-report-ready-p + (lime.core:preflight-activity-draft candidate (getf h :id) (getf a :id)))))) + ;; Apply only after the copy has passed. Preserve world and + ;; surviving Presentation identities held by REPL clients. + (setf migration (lime.core::normalize-activity-arrangements + world :preferred-presentation-ids preferred)) + (assert (equal migration candidate-migration)) + (assert (equalp after (lime.persistence:snapshot-world world)))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal slots (lime.x11:backend-navigation-slots backend))) + (lime.x11::render-head-bars backend) + (xlib:display-finish-output (lime.x11::x11-backend-display backend)) + (list :upgraded t :active-arrangements-unchanged t :saved-views-unchanged t + :configuration-unchanged t :slots-unchanged t + :retired-records (length (getf migration :retired-arrangements)) + :removed-old-locations (length (getf migration :removed-old-locations)) + :function-count (length definitions))) + (error (condition) + ;; Restore original objects and function definitions, not a restart. + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (clrhash (lime.core::world-presentations world)) + (dolist (record records) + (let ((p (car record)) (old (cdr record))) + (dolist (slot '(lime.core::placements lime.core::layout-root lime.core::focus-client-id + lime.core::unavailable-client-ids lime.core::dirty-p lime.core::source-view-id)) + (setf (slot-value p slot) (slot-value old slot))) + (setf (gethash (lime.core:presentation-id p) (lime.core::world-presentations world)) p))) + (setf (lime.core:world-revision world) revision) + (when old-nav (setf (gethash backend lime.x11::*backend-navigation-states*) old-nav)) + (ignore-errors (lime.x11::render-head-bars backend)) + (error condition)))))) diff --git a/work/upgrade-live-cursor-session.lisp b/work/upgrade-live-cursor-session.lisp new file mode 100644 index 0000000..a3da0bf --- /dev/null +++ b/work/upgrade-live-cursor-session.lisp @@ -0,0 +1,79 @@ +;;;; Add display-local application cursor settings without reloading WM structs. +(in-package #:cl-user) +(declaim (special lime.x11::*cursor-session-settings*)) + +(defun lime-cursor-session-definitions () + (let ((manifest '(("src/x11/cursor.lisp" "%CURSOR-THEME-NAME-P" "%VALIDATE-UI-CURSOR-STYLE" + "%BACKEND-CURSOR-SETTINGS" "BACKEND-CURSOR-REPORT") + ("src/x11/launcher.lisp" "BACKEND-LAUNCH-PROGRAM") + ("src/x11/backend.lisp" "%DISPATCH-NEXT-EVENT" "STOP-BACKEND") + ("src/x11/config.lisp" "APPLY-LIME-CONFIGURATION"))) + (definitions nil) (*package* (find-package :lime.x11)) (*read-eval* nil)) + (dolist (entry manifest) + (destructuring-bind (file &rest names) entry + (let ((symbols (mapcar (lambda (name) (intern name *package*)) names)) (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-cursor-session () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (when (and (boundp 'lime.x11::*cursor-session-settings*) + (gethash backend lime.x11::*cursor-session-settings*)) + (error "Cursor session publisher is already installed; do not repeat this upgrade.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (head (lime.x11:x11-backend-focused-head-id backend)) + (display (lime.x11::x11-backend-display backend)) + (focus (xlib:input-focus display)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (cursors (lime.x11::x11-backend-cursor-set backend)) + (selection (intern (format nil "_XSETTINGS_S~D" + (position (lime.x11::x11-backend-x-screen backend) + (xlib:display-roots display))) :keyword)) + (owner (xlib:selection-owner display selection)) + (definitions (lime-cursor-session-definitions)) + (old-functions (mapcar (lambda (form) (cons (second form) (fdefinition (second form)))) definitions))) + (assert config) + (assert (equal "Bibata-Original-Ice" (lime.x11:ui-cursor-style-theme (lime.x11:lime-configuration-cursor config)))) + (assert (= 24 (lime.x11:ui-cursor-style-size (lime.x11:lime-configuration-cursor config)))) + (handler-case + (progn + ;; New module only: no redefinition of backend/model structures. + (load #p"/home/adan/code/common-lisp/lime/src/x11/session-settings.lisp") + (dolist (definition definitions) (eval definition)) + (lime.x11::%apply-cursor-session-settings backend (lime.x11:lime-configuration-cursor config)) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (equal head (lime.x11:x11-backend-focused-head-id backend))) + (let ((after-focus (xlib:input-focus display))) + (assert (or (eql focus after-focus) + (and (typep focus 'xlib:window) (typep after-focus 'xlib:window) + (xlib:window-equal focus after-focus))))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (eq cursors (lime.x11::x11-backend-cursor-set backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (when owner (assert (xlib:window-equal owner (xlib:selection-owner display selection)))) + (list :upgraded t :functions (length definitions) :world-unchanged t + :focus-unchanged t :bindings-unchanged t :configuration-unchanged t + :previous-settings-manager (and owner (xlib:window-id owner)) + :cursor-session (lime.x11::%cursor-session-report backend))) + (error (condition) + (when (fboundp 'lime.x11::%shutdown-cursor-session-settings) + (ignore-errors (lime.x11::%shutdown-cursor-session-settings backend))) + (dolist (entry old-functions) (setf (fdefinition (car entry)) (cdr entry))) + (ignore-errors (xlib:display-finish-output display)) + (error condition)))))) diff --git a/work/upgrade-live-follow-head.lisp b/work/upgrade-live-follow-head.lisp new file mode 100644 index 0000000..2586b7e --- /dev/null +++ b/work/upgrade-live-follow-head.lisp @@ -0,0 +1,52 @@ +;;;; Function-only upgrade; no test transfers on the user's live desk. +(in-package #:cl-user) + +(defun lime-follow-head-definitions () + (let ((manifest '(("src/x11/commands.lisp" "BACKEND-TRANSFER-FOCUSED-CLIENT-TO-HEAD" + "BACKEND-TRANSFER-FOCUSED-CLIENT-RELATIVELY" "BACKEND-REHOME-CLIENT-TO-HEAD") + ("src/x11/ui.lisp" "%UI-REQUEST-CLIENT-SEND"))) + (definitions nil) + (*package* (find-package :lime.x11)) (*read-eval* nil)) + (dolist (entry manifest) + (destructuring-bind (file &rest names) entry + (let ((symbols (mapcar (lambda (name) (or (find-symbol name *package*) (error "Missing ~A" name))) names)) + (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-follow-head () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (head (lime.x11:x11-backend-focused-head-id backend)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (definitions (lime-follow-head-definitions)) + (old-functions (mapcar (lambda (form) (cons (second form) (fdefinition (second form)))) definitions))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (equal head (lime.x11:x11-backend-focused-head-id backend))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :focus-unchanged t :bindings-unchanged t + :function-count (length definitions))) + (error (condition) + (dolist (entry old-functions) (setf (fdefinition (car entry)) (cdr entry))) + (error condition)))))) diff --git a/work/upgrade-live-head-send.lisp b/work/upgrade-live-head-send.lisp new file mode 100644 index 0000000..2ade385 --- /dev/null +++ b/work/upgrade-live-head-send.lisp @@ -0,0 +1,82 @@ +;;;; Function-only upgrade; never performs a transfer on the user's desk. +(in-package #:cl-user) + +(defun lime-head-send-definitions () + ;; Export before reading X11 source so its inherited core symbol resolves + ;; correctly in a runtime that has not loaded the new package definition. + (export 'lime.core::move-client-to-presentation :lime.core) + (let ((manifest + '((:lime.core "src/membership.lisp" + "%MOVE-CLIENT-MEMBERSHIP" "MOVE-CLIENT-TO-ACTIVITY" "MOVE-CLIENT-TO-PRESENTATION") + (:lime.x11 "src/x11/commands.lisp" + "BACKEND-TRANSFER-FOCUSED-CLIENT-TO-HEAD" "BACKEND-REHOME-CLIENT-TO-HEAD") + (:lime.x11 "src/x11/ui.lisp" + "%UI-SEND-CONTEXT-VALID-P" "%UI-REQUEST-CLIENT-SEND" + "BACKEND-SEND-FOCUSED-CLIENT-TO-HEAD" "BACKEND-SEND-FOCUSED-CLIENT-RELATIVELY" + "%UI-KEY-PATH") + (:lime.x11 "src/x11/default-bindings.lisp" "INSTALL-DEFAULT-KEYBINDINGS"))) + (definitions nil)) + (dolist (entry manifest) + (destructuring-bind (package file &rest names) entry + (let* ((*package* (find-package package)) (*read-eval* nil) + (symbols (mapcar (lambda (name) (intern name *package*)) names)) + (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-head-send () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (command (lime.x11:find-configured-command backend 'send-window-to-next-head)) + (old-detail (lime.x11:lime-command-description command)) + (old-action (lime.x11:lime-command-action command)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (definitions (lime-head-send-definitions)) + (old-functions + (mapcar (lambda (form) + (let ((name (second form))) + (cons name (and (fboundp name) (fdefinition name))))) + definitions))) + (assert (equal "/home/adan/.config/lime/config.lisp" + (lime.x11::x11-backend-configuration-source backend))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + (export '(lime.x11::backend-rehome-client-to-head + lime.x11::backend-send-focused-client-to-head + lime.x11::backend-send-focused-client-relatively) :lime.x11) + ;; Existing binding closures resolve the command by id; no key + ;; regrabs, provider restarts, or session/config reload necessary. + (setf (lime.x11:lime-command-description command) + "Send to next monitor; confirm if its Activity changes" + (lime.x11:lime-command-action command) + (lambda (backend) (lime.x11::backend-send-focused-client-relatively backend :next))) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :bindings-unchanged t + :function-count (length definitions) + :command (lime.x11:lime-command-label command))) + (error (condition) + (setf (lime.x11:lime-command-description command) old-detail + (lime.x11:lime-command-action command) old-action) + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (error condition)))))) diff --git a/work/upgrade-live-launcher-input.lisp b/work/upgrade-live-launcher-input.lisp new file mode 100644 index 0000000..014a606 --- /dev/null +++ b/work/upgrade-live-launcher-input.lisp @@ -0,0 +1,69 @@ +;;;; Hotload the launcher cache and synchronous passive-grab handoff only. +(in-package #:cl-user) +(defvar lime.x11::*path-program-cache* nil) + +(defun lime-launcher-input-definitions () + (let ((manifest '(("src/x11/launcher.lisp" "%NORMALIZE-PROGRAM-NAMES" "%SCAN-PATH-PROGRAM-NAMES" + "%PATH-PROGRAM-SIGNATURE" "%PATH-PROGRAM-NAMES") + ("src/x11/input.lisp" "BIND-KEY" "%HANDLE-KEY-PRESS"))) + (definitions nil) (*package* (find-package :lime.x11)) (*read-eval* nil)) + (dolist (entry manifest) + (destructuring-bind (file &rest names) entry + (let ((symbols (mapcar (lambda (name) (intern name *package*)) names)) (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-launcher-input () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (head (lime.x11:x11-backend-focused-head-id backend)) + (display (lime.x11::x11-backend-display backend)) + (root (lime.x11::x11-backend-root backend)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (old-cache lime.x11::*path-program-cache*) + (definitions (lime-launcher-input-definitions)) + (old-functions (mapcar (lambda (form) + (cons (second form) (and (fboundp (second form)) (fdefinition (second form))))) + definitions))) + (flet ((regrab (synchronous-p) + ;; Replace our own existing grabs in place: no ungrab interval, + ;; no remapping, no config reload, no change to handler closures. + (dolist (binding bindings) + (dolist (code (lime.x11::keybinding-keycodes binding)) + (dolist (state (lime.x11::%input-state-variants (lime.x11::keybinding-state binding))) + (xlib:grab-key root code :modifiers state :sync-keyboard-p synchronous-p)))) + (xlib:display-finish-output display))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + (let ((program-count (length (lime.x11::%path-program-names :refresh-p t)))) + (regrab t) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (equal head (lime.x11:x11-backend-focused-head-id backend))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :focus-unchanged t :bindings-unchanged t + :keyboard-handoff-updated t :cached-programs program-count))) + (error (condition) + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (setf lime.x11::*path-program-cache* old-cache) + (ignore-errors (regrab nil)) + (ignore-errors (xlib:allow-events display :async-keyboard) (xlib:display-force-output display)) + (error condition))))))) diff --git a/work/upgrade-live-portable-activities.lisp b/work/upgrade-live-portable-activities.lisp new file mode 100644 index 0000000..f6e0238 --- /dev/null +++ b/work/upgrade-live-portable-activities.lisp @@ -0,0 +1,120 @@ +;;;; Guarded function-only upgrade: preserve every live model object and XID. +(in-package #:cl-user) +(declaim (special lime.x11::*backend-activity-navigation-states*)) + +(defun lime-portable-definitions () + (let ((manifest + '((:lime.core "src/membership.lisp" "%MOVE-CLIENT-MEMBERSHIP" "MOVE-CLIENT-TO-ACTIVITY") + (:lime.x11 "src/x11/navigation.lisp" "%FORGET-NAVIGATION-STATE" + "BACKEND-PREFLIGHT-ACTIVITY-SWITCH" "BACKEND-SWITCH-TO-ACTIVITY") + (:lime.x11 "src/x11/commands.lisp" "BACKEND-MOVE-CLIENT-TO-ACTIVITY" + "BACKEND-ACTIVATE-ACTIVITY" "BACKEND-PREFLIGHT-ACTIVITY-ACTIVATION" + "BACKEND-PREFLIGHT-VIEW-ACTIVATION" "BACKEND-ACTIVATE-VIEW") + (:lime.x11 "src/x11/ui.lisp" "%UI-ACTIVITY-CANDIDATES" "%UI-MOVE-CLIENT-RESULT" + "%UI-REQUEST-ACTIVITY-ACTIVATION" "%COMMAND-PALETTE-CANDIDATES" "%UI-KEY-PATH") + (:lime.x11 "src/x11/persistence.lisp" "%VALIDATE-SESSION-ENVELOPE" + "%PREPARE-SESSION-PERSISTENCE" "%SESSION-SIGNATURE" "%SESSION-SNAPSHOT"))) + (definitions nil) (*read-eval* nil)) + (dolist (entry manifest) + (destructuring-bind (package file &rest names) entry + (let* ((*package* (find-package package)) + (symbols (mapcar (lambda (name) (intern name *package*)) names)) (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-portable-activities () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (when (and (boundp 'lime.x11::*backend-activity-navigation-states*) + (gethash backend lime.x11::*backend-activity-navigation-states*)) + (error "Portable navigation is already installed; do not repeat this migration.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (head (lime.x11:x11-backend-focused-head-id backend)) + (display (lime.x11::x11-backend-display backend)) + (focus (xlib:input-focus display)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (leases (loop for id being the hash-keys of (lime.core::world-leases world) + using (hash-value lease) collect (cons id lease))) + (session (lime.x11:backend-save-session backend :wait-p t)) + (old-data (lime.x11::%session-snapshot backend)) + (backup-directory (uiop:ensure-directory-pathname + (string-trim '(#\Newline) + (uiop:run-program '("mktemp" "-d" "/home/adan/.local/state/lime/pre-portable-XXXXXX") + :output :string)))) + (backup-file (merge-pathnames "session-v2.sexp" backup-directory))) + ;; The owner thread cannot autosave a newer snapshot during this block. + ;; Waiting above drains the writer before making this private backup. + (assert (= 2 (getf old-data :version))) + (uiop:copy-file (getf session :file) backup-file) + (uiop:run-program (list "chmod" "600" (namestring backup-file))) + (export (mapcar (lambda (name) (intern name :lime.core)) + '("ACTIVITY-PRESENTATIONS" "PREFLIGHT-PRESENTATION-BRING" "BRING-PRESENTATION-TO-HEAD")) :lime.core) + (export (mapcar (lambda (name) (intern name :lime.x11)) + '("BACKEND-ACTIVITY-NAVIGATION-MODE" "BACKEND-EXTEND-ACTIVITY-TO-HEAD" + "BACKEND-MAKE-ACTIVITY-PORTABLE")) :lime.x11) + (let* ((definitions (lime-portable-definitions)) + (old-functions (mapcar (lambda (form) (cons (second form) (fdefinition (second form)))) definitions)) + (copy-checks 0) (policies nil)) + (handler-case + (progn + ;; New modules only: no existing DEFSTRUCT layout is redefined. + (dolist (file '("src/presentation-navigation.lisp" "src/x11/activity-navigation.lisp" + "src/x11/activity-navigation-ui.lisp")) + (load (merge-pathnames file #p"/home/adan/code/common-lisp/lime/"))) + (dolist (definition definitions) (eval definition)) + ;; Test migration and actual bring/swap transitions on a detached + ;; copy of this user's exact saved world before enabling policy. + (multiple-value-bind (candidate navigation footprint) + (lime.x11::%validate-session-envelope old-data) + (declare (ignore navigation)) + (assert (equalp before (lime.persistence:snapshot-world candidate))) + (setf policies (copy-tree (lime.x11::activity-navigation-state-rows footprint))) + (dolist (row policies) + (when (and (eq :portable (second row)) (third row)) + (dolist (destination (lime.x11:backend-head-ids backend)) + (lime.core::bring-presentation-to-head candidate (third row) destination) + (assert (lime.core:validate-world candidate)) + (incf copy-checks))))) + ;; Hash-table iteration order need not survive snapshot/restore. + (let ((live-policies (lime.x11::%activity-navigation-snapshot backend))) + (assert (= (length policies) (length live-policies))) + (dolist (row policies) + (assert (equal row (assoc (first row) live-policies :test #'equal))))) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (equal head (lime.x11:x11-backend-focused-head-id backend))) + (let ((after-focus (xlib:input-focus display))) + (assert (or (eql focus after-focus) + (and (typep focus 'xlib:window) (typep after-focus 'xlib:window) + (xlib:window-equal focus after-focus))))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (= (length leases) (hash-table-count (lime.core::world-leases world)))) + (dolist (entry leases) (assert (eq (cdr entry) (lime.core:lease-for-client world (car entry))))) + (assert (= 3 (getf (lime.x11::%session-snapshot backend) :version)))) + (error (condition) + (dolist (entry old-functions) (setf (fdefinition (car entry)) (cdr entry))) + (when (boundp 'lime.x11::*backend-activity-navigation-states*) + (remhash backend lime.x11::*backend-activity-navigation-states*)) + (error "Portable upgrade rolled back; backup ~A. ~A" backup-file condition))) + ;; The code/model transaction has committed; a disk failure here must + ;; keep the new running code, whose normal autosave retry can recover. + (let ((save (handler-case (lime.x11:backend-save-session backend :wait-p t) + (error (c) (list :error (princ-to-string c)))))) + (list :upgraded t :functions (length definitions) :backup (namestring backup-file) + :world-unchanged t :focus-unchanged t :bindings-unchanged t :lease-objects-unchanged t + :migration-copy-swaps-tested copy-checks + :policies (mapcar (lambda (row) (subseq row 0 2)) policies) + :session-save save)))))) diff --git a/work/upgrade-live-private-here.lisp b/work/upgrade-live-private-here.lisp new file mode 100644 index 0000000..8373ba7 --- /dev/null +++ b/work/upgrade-live-private-here.lisp @@ -0,0 +1,61 @@ +;;;; Function-only upgrade; never changes a live window's membership. +(in-package #:cl-user) + +(defun lime-private-here-definitions () + ;; Resolve the inherited core symbol correctly before reading adapter forms. + (export 'lime.core::make-client-private-in-presentation :lime.core) + (let ((manifest + '((:lime.core "src/membership.lisp" "MAKE-CLIENT-PRIVATE-IN-PRESENTATION") + (:lime.x11 "src/x11/commands.lisp" "BACKEND-MAKE-CLIENT-PRIVATE" "BACKEND-SET-CLIENT-SHARED") + (:lime.x11 "src/x11/ui.lisp" "%UI-PRIVATE-CONTEXT-VALID-P" + "%UI-SET-CLIENT-SHARING-RESULT" "%UI-MEMBERSHIP-CANDIDATES"))) + (definitions nil)) + (dolist (entry manifest) + (destructuring-bind (package file &rest names) entry + (let* ((*package* (find-package package)) (*read-eval* nil) + (symbols (mapcar (lambda (name) (intern name *package*)) names)) + (found nil)) + (with-open-file (in (merge-pathnames file #p"/home/adan/code/common-lisp/lime/")) + (loop for form = (read in nil :eof) until (eq form :eof) + when (and (consp form) (eq (first form) 'defun) (member (second form) symbols)) + do (push form found))) + (assert (= (length symbols) (length found))) + (dolist (symbol symbols) (assert (find symbol found :key #'second))) + (setf definitions (append definitions + (mapcar (lambda (symbol) (find symbol found :key #'second)) symbols)))))) + definitions)) + +(defun lime-upgrade-live-private-here () + (unless (= 1578331 (slynk-backend:getpid)) (error "Unexpected Lime process.")) + (lime.dev:with-development-backend (backend) + (unless (and (lime.dev::development-session-running-p lime.dev:*development-session*) + (not (lime.dev::development-session-paused-p lime.dev:*development-session*))) + (error "Lime is not running normally.")) + (when (or (lime.x11::x11-backend-pointer-drag backend) + (lime.x11::x11-backend-ui-session backend)) + (error "Close the menu or finish the drag before upgrading.")) + (let* ((world (lime.x11:x11-backend-world backend)) + (before (lime.persistence:snapshot-world world)) + (head (lime.x11:x11-backend-focused-head-id backend)) + (config (lime.x11::x11-backend-configuration backend)) + (bindings (lime.x11:list-keybindings backend)) + (definitions (lime-private-here-definitions)) + (old-functions + (mapcar (lambda (form) + (let ((name (second form))) + (cons name (and (fboundp name) (fdefinition name))))) definitions))) + (handler-case + (progn + (dolist (definition definitions) (eval definition)) + (export 'lime.x11::backend-make-client-private :lime.x11) + (assert (equalp before (lime.persistence:snapshot-world world))) + (assert (equal head (lime.x11:x11-backend-focused-head-id backend))) + (assert (eq config (lime.x11::x11-backend-configuration backend))) + (assert (equal bindings (lime.x11:list-keybindings backend))) + (assert (lime.core:validate-world world)) + (list :upgraded t :world-unchanged t :focus-unchanged t :bindings-unchanged t + :function-count (length definitions))) + (error (condition) + (dolist (entry old-functions) + (if (cdr entry) (setf (fdefinition (car entry)) (cdr entry)) (fmakunbound (car entry)))) + (error condition))))))