gansito05/lime
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Lime window manager

Browse Source
This commit is contained in:
Adan
2026-10-02 14:14:47 -05:00
commit 785c2e8968
103 changed files with 27259 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
.gitignore vendored Normal file
View File

@@ -0,0 +1,10 @@
*.fasl
*.dfsl
*.lx64fsl
*.dx64fsl
*.x86f
*.log
/.cache/
# Local development scratchpad: mockups and one-off helper scripts.
/work/

313
README.md Normal file
View File

@@ -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.

487
docs/architecture.md Normal file
View File

@@ -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.

78
docs/attention.md Normal file
View File

@@ -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).

674
docs/configuration.md Normal file
View File

@@ -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.

221
docs/development.md Normal file
View File

@@ -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-<display>.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.

308
docs/model.md Normal file
View File

@@ -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.

149
docs/persistence.md Normal file
View File

@@ -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.

686
docs/xephyr-demo.md Normal file
View File

@@ -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.

139
lime.asd Normal file
View File

@@ -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)))

191
scripts/run-xephyr-dev Executable file
View File

@@ -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 <<EOF
Usage: $(basename "$0") [options]
Start Lime in a disposable Xephyr session from the current desktop.
-c, --config PATH Load this Lime configuration file.
--no-config Use Lime's starter bindings instead of a config file.
-d, --display NAME Nested display name (default: :99).
-s, --screen SIZE Xephyr size (default: 1600x1000).
-p, --repl-port N Loopback Slynk port (default: 4005).
--session-file PATH Use a specific saved desk (separate from configuration).
--no-session Disable session restore/autosave for a disposable test.
-h, --help Show this help.
Without an explicit config choice, the runner loads
$default_config_file
when it exists; otherwise it uses the starter bindings.
Session data defaults to Lime's XDG state directory, separated by DISPLAY.
EOF
}
while (($#)); do
case "$1" in
-c|--config)
[[ $# -ge 2 ]] || { printf '%s needs a path.\n' "$1" >&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")))'

46
src/conditions.lisp Normal file
View File

@@ -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)))))

102
src/floating-operations.lisp Normal file
View File

@@ -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))

304
src/layout-operations.lisp Normal file
View File

@@ -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))))

209
src/layout.lisp Normal file
View File

@@ -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)))

276
src/membership.lisp Normal file
View File

@@ -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)))

698
src/model.lisp Normal file
View File

@@ -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))

1125
src/operations.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

256
src/package.lisp Normal file
View File

@@ -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))

246
src/persistence/model.lisp Normal file
View File

@@ -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))

6
src/persistence/package.lisp Normal file
View File

@@ -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))

122
src/persistence/store.lisp Normal file
View File

@@ -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))))))))

77
src/presentation-navigation.lisp Normal file
View File

@@ -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))))

211
src/topology.lisp Normal file
View File

@@ -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)))))

48
src/ui/package.lisp Normal file
View File

@@ -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))

365
src/ui/session.lisp Normal file
View File

@@ -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))))

335
src/viewset.lisp Normal file
View File

@@ -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))))

63
src/x11/activity-navigation-ui.lisp Normal file
View File

@@ -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))))))

149
src/x11/activity-navigation.lisp Normal file
View File

@@ -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))

120
src/x11/appearance.lisp Normal file
View File

@@ -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)))))

103
src/x11/attention.lisp Normal file
View File

@@ -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))))

669
src/x11/backend.lisp Normal file
View File

@@ -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))))

774
src/x11/bar.lisp Normal file
View File

@@ -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))))

1061
src/x11/commands.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

13
src/x11/config-package.lisp Normal file
View File

@@ -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))

891
src/x11/config.lisp Normal file
View File

@@ -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))

211
src/x11/cursor.lisp Normal file
View File

@@ -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))))))

177
src/x11/default-bindings.lisp Normal file
View File

@@ -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")))))

33
src/x11/development-package.lisp Normal file
View File

@@ -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))

505
src/x11/development.lisp Normal file
View File

@@ -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)))

472
src/x11/ewmh.lisp Normal file
View File

@@ -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)

102
src/x11/geometry.lisp Normal file
View File

@@ -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))))))

231
src/x11/icccm.lisp Normal file
View File

@@ -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))

186
src/x11/input.lisp Normal file
View File

@@ -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)))))

144
src/x11/launcher.lisp Normal file
View File

@@ -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"))))

178
src/x11/lifecycle.lisp Normal file
View File

@@ -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)

234
src/x11/navigation.lisp Normal file
View File

@@ -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)))))

316
src/x11/package.lisp Normal file
View File

@@ -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))

319
src/x11/persistence.lisp Normal file
View File

@@ -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))))))

183
src/x11/placement-policy.lisp Normal file
View File

@@ -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)))))))))))

285
src/x11/pointer.lisp Normal file
View File

@@ -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))

348
src/x11/randr.lisp Normal file
View File

@@ -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)))

286
src/x11/render.lisp Normal file
View File

@@ -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))

154
src/x11/resilience.lisp Normal file
View File

@@ -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)

239
src/x11/session-settings.lisp Normal file
View File

@@ -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)))

265
src/x11/status-desktop.lisp Normal file
View File

@@ -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)))

41
src/x11/status-format.lisp Normal file
View File

@@ -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)))

234
src/x11/status.lisp Normal file
View File

@@ -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))))))

65
src/x11/text-native.lisp Normal file
View File

@@ -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))

281
src/x11/text.lisp Normal file
View File

@@ -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)))

295
src/x11/ui-render.lisp Normal file
View File

@@ -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))))))

1451
src/x11/ui.lisp Normal file
View File

File diff suppressed because it is too large Load Diff

12
test/config-fixture.lisp Normal file
View File

@@ -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)))

3
test/development-package.lisp Normal file
View File

@@ -0,0 +1,3 @@
(defpackage #:lime.dev.test
(:use #:cl #:fiveam #:lime.dev)
(:export #:run-tests))

54
test/development.lisp Normal file
View File

@@ -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))

30
test/gtk-cursor-probe.py Normal file
View File

@@ -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()

422
test/membership.lisp Normal file
View File

@@ -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)))))

955
test/model.lisp Normal file
View File

@@ -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))

3
test/package.lisp Normal file
View File

@@ -0,0 +1,3 @@
(defpackage #:lime.test
(:use #:cl #:fiveam #:lime.core)
(:export #:run-tests))

215
test/persistence.lisp Normal file
View File

@@ -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.")))

85
test/presentation-navigation.lisp Normal file
View File

@@ -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))))

2
test/ui-package.lisp Normal file
View File

@@ -0,0 +1,2 @@
(defpackage #:lime.ui.test
(:use #:cl #:fiveam #:lime.ui))

209
test/ui.lisp Normal file
View File

@@ -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))

109
test/x11-activity-navigation.lisp Normal file
View File

@@ -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)))))

8
test/x11-appearance-config.lisp Normal file
View File

@@ -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"))

415
test/x11-appearance-smoke.lisp Normal file
View File

@@ -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)))

233
test/x11-attention-smoke.lisp Normal file
View File

@@ -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)))

149
test/x11-attention.lisp Normal file
View File

@@ -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)))))

177
test/x11-cursor-smoke.lisp Normal file
View File

@@ -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))))

36
test/x11-cursor.lisp Normal file
View File

@@ -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")))))

16
test/x11-default-layout-config.lisp Normal file
View File

@@ -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*))))

91
test/x11-default-layout-smoke.lisp Normal file
View File

@@ -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)))

143
test/x11-fixed-size-smoke.lisp Normal file
View File

@@ -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)))

238
test/x11-floating-smoke.lisp Normal file
View File

@@ -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)))

163
test/x11-font-smoke.lisp Normal file
View File

@@ -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))))

175
test/x11-head-send-smoke.lisp Normal file
View File

@@ -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)))

124
test/x11-launcher-smoke.lisp Normal file
View File

@@ -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)))

196
test/x11-membership-smoke.lisp Normal file
View File

@@ -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)))

281
test/x11-membership.lisp Normal file
View File

@@ -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")))))))

261
test/x11-navigation-smoke.lisp Normal file
View File

@@ -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)))

266
test/x11-navigation.lisp Normal file
View File

@@ -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))))))

3
test/x11-package.lisp Normal file
View File

@@ -0,0 +1,3 @@
(defpackage #:lime.x11.test
(:use #:cl #:fiveam #:lime.core #:lime.ui #:lime.x11)
(:export #:run-tests))

199
test/x11-persistence-smoke.lisp Normal file
View File

@@ -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)))

227
test/x11-pointer-ui-smoke.lisp Normal file
View File

@@ -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)))

139
test/x11-portable-activities-smoke.lisp Normal file
View File

@@ -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)))

301
test/x11-resilience-smoke.lisp Normal file
View File

@@ -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)))

177
test/x11-session-settings-smoke.lisp Normal file
View File

@@ -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)))

50
test/x11-session-settings.lisp Normal file
View File

@@ -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*))))

191
test/x11-status-smoke.lisp Normal file
View File

@@ -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)))

235
test/x11-status.lisp Normal file
View File

@@ -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)))))

Some files were not shown because too many files have changed in this diff Show More