892 lines
44 KiB
Common Lisp
892 lines
44 KiB
Common Lisp
(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))
|