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