Initial Lime window manager
This commit is contained in:
365
src/ui/session.lisp
Normal file
365
src/ui/session.lisp
Normal 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))))
|
||||
Reference in New Issue
Block a user