mirror of
https://github.com/stumpwm/stumpwm.git
synced 2026-09-10 07:26:20 -04:00
4ddd460003
run-menu currently tries to funcall action regardless of whether its a function or not, which conflicts with help keys returning t as the action. With this commit we check if action is a function. additionally if we are displaying help bindings, we dont overwrite the message window until the user presses a key, and we allow abort keys to remove the message window instead of aborting the menu.
475 lines
19 KiB
Common Lisp
475 lines
19 KiB
Common Lisp
;; Copyright (C) 2018 Stuart Dilts
|
|
;;
|
|
;; This file is part of stumpwm.
|
|
;;
|
|
;; stumpwm is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; stumpwm is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this software; see the file COPYING. If not, see
|
|
;; <http://www.gnu.org/licenses/>.
|
|
|
|
;; Commentary:
|
|
;;
|
|
;; Implementation of an interactive menu. This file contains the definitions of the menu
|
|
;; class as defined in menu-declarations.lisp.
|
|
;;
|
|
;; Code:
|
|
|
|
;;; interactive menu
|
|
|
|
(in-package #:stumpwm)
|
|
|
|
(export '(entries-from-nested-list
|
|
select-from-menu
|
|
select-from-batch-menu
|
|
command-menu))
|
|
|
|
(defun entries-from-nested-list (lst)
|
|
(mapcar (lambda (x)
|
|
(make-instance 'menu-entry
|
|
:label (car x)
|
|
:data (cadr x)))
|
|
lst))
|
|
|
|
(defmethod menu-entry-display ((entry menu-entry))
|
|
(concat (string (menu-entry-icon entry)) " " (menu-entry-label entry)))
|
|
|
|
(defmethod menu-entry-apply ((entry menu-entry) function)
|
|
(if (slot-boundp entry 'data)
|
|
(values (apply function (menu-entry-data entry)) t)
|
|
(values nil nil)))
|
|
|
|
|
|
(defmethod print-object ((obj menu-entry) out)
|
|
(print-unreadable-object (obj out :type t)
|
|
(format out ":LABEL ~s :ICON ~s :DATA ~a"
|
|
(menu-entry-label obj) (menu-entry-icon obj)
|
|
(when (slot-boundp obj 'data)
|
|
(menu-entry-data obj)))))
|
|
|
|
|
|
(defun menu-scrolling-required (menu)
|
|
(and *menu-maximum-height*
|
|
(> (length (menu-table menu))
|
|
*menu-maximum-height*)))
|
|
|
|
(defun menu-height (menu)
|
|
(let ((len (length (menu-table menu))))
|
|
(min (or *menu-maximum-height* len) len)))
|
|
|
|
(defun bound-check-menu (menu)
|
|
"Adjust the menu view and selected item based
|
|
on current view and new selection."
|
|
(let ((len (length (menu-table menu))))
|
|
;; Wrap around
|
|
(setf (menu-selected menu)
|
|
(cond ((< (menu-selected menu) 0) (1- len))
|
|
((>= (menu-selected menu) len) 0)
|
|
(t (menu-selected menu))))
|
|
(setf (values (menu-view-start menu)
|
|
(menu-view-end menu))
|
|
(if (zerop len)
|
|
(values 0 0)
|
|
(let* ((menu-height (menu-height menu))
|
|
(sel (menu-selected menu))
|
|
(start (- sel 1))
|
|
(end (+ sel menu-height -1)))
|
|
(multiple-value-bind
|
|
(start end) (cond ((< start 0) (values 0 menu-height))
|
|
((> end len) (values (- len menu-height) len))
|
|
(t (values start end)))
|
|
(assert (<= 0 start (- len menu-height)) (start))
|
|
(assert (<= menu-height end len) (end))
|
|
(values start end)))))))
|
|
|
|
(defmethod menu-up ((menu menu))
|
|
(decf (menu-selected menu))
|
|
(bound-check-menu menu))
|
|
|
|
;; before or after? probably doesn't matter
|
|
(defmethod menu-up :before ((menu single-menu))
|
|
"clear the search string if the cursor is moved"
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0))
|
|
|
|
(defmethod menu-down ((menu menu))
|
|
(incf (menu-selected menu))
|
|
(bound-check-menu menu))
|
|
|
|
(defmethod menu-down :before ((menu single-menu))
|
|
"clear the search string if the cursor is moved"
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0))
|
|
|
|
(defmethod menu-scroll-up ((menu menu))
|
|
(decf (menu-selected menu) *menu-scrolling-step*)
|
|
(bound-check-menu menu))
|
|
|
|
(defmethod menu-scroll-up :before ((menu single-menu))
|
|
"clear the search string if the cursor is moved"
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0))
|
|
|
|
(defmethod menu-scroll-down ((menu menu))
|
|
(incf (menu-selected menu) *menu-scrolling-step*)
|
|
(bound-check-menu menu))
|
|
|
|
(defmethod menu-scroll-down :before ((menu single-menu))
|
|
"clear the search string if the cursor is moved"
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0))
|
|
|
|
(defmethod menu-page-up ((menu menu))
|
|
(when *menu-maximum-height* ;;No scrolling = no page up/down
|
|
(decf (menu-selected menu) *menu-maximum-height*)
|
|
(let ((*menu-scrolling-step* *menu-maximum-height*))
|
|
(bound-check-menu menu))))
|
|
|
|
(defmethod menu-page-up :before ((menu single-menu))
|
|
(when *menu-maximum-height* ;;No scrolling = no page up/down
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0)))
|
|
|
|
(defmethod menu-page-down ((menu menu))
|
|
(when *menu-maximum-height*
|
|
(incf (menu-selected menu) *menu-maximum-height*)
|
|
(let ((*menu-scrolling-step* *menu-maximum-height*))
|
|
(bound-check-menu menu))))
|
|
|
|
(defmethod menu-page-down :before ((menu single-menu))
|
|
(when *menu-maximum-height*
|
|
(setf (fill-pointer (single-menu-current-input menu)) 0)))
|
|
|
|
(defmethod menu-finish ((menu menu))
|
|
(throw :menu-quit (nth (menu-selected menu) (menu-table menu))))
|
|
|
|
(defmethod menu-finish ((menu batch-menu))
|
|
"Value returned with the signal is an alist, where the cdr of the value
|
|
returned by assoc is a list items that were marked with that character.
|
|
Example when entry1 and entry2 are marked with 'a', and entry3 is not marked:
|
|
((a entry1 entry2) (NIL entry3))"
|
|
(with-slots (allowed-markers table) menu
|
|
(let ((alist (list)))
|
|
(dolist (entry table)
|
|
(let ((mark (car entry))
|
|
(value (cdr entry)))
|
|
(if-let ((cell (assoc mark alist)))
|
|
(push value (cdr cell))
|
|
(setf alist (acons mark (list value) alist)))))
|
|
(throw :menu-quit alist))))
|
|
|
|
(defmethod menu-abort (menu)
|
|
(declare (ignore menu))
|
|
(throw :menu-quit nil))
|
|
|
|
(defun get-input-char (key)
|
|
"If @var{key} is a character suitable for menu completion (e.g. not
|
|
backspace or F9), return it otherwise return nil"
|
|
(let ((char (xlib:keysym->character *display* (key-keysym key))))
|
|
(if (or (key-mods-p key) (null char)
|
|
(not (characterp char)))
|
|
nil
|
|
char)))
|
|
|
|
;; menu-backspace might be in someone's custom *menu-map*:
|
|
;; leave this here just to be safe:
|
|
(defmethod menu-backspace ((menu menu))
|
|
(declare (ignore menu))
|
|
"By default, do nothing")
|
|
|
|
(defun batch-menu-unmark-selected (menu)
|
|
(with-accessors ((table menu-table)
|
|
(selected menu-selected))
|
|
menu
|
|
(setf (car (nth selected table)) nil)))
|
|
|
|
(defmethod menu-backspace ((menu batch-menu))
|
|
"If the cursor is not at the top, move cursor up. Regardless,
|
|
unmark the entry at the selected point."
|
|
(when (> (menu-selected menu) 0)
|
|
(menu-up menu))
|
|
(batch-menu-unmark-selected menu))
|
|
|
|
(defmethod menu-backspace ((menu single-menu))
|
|
(when (> (fill-pointer (single-menu-current-input menu)) 0)
|
|
(vector-pop (single-menu-current-input menu))
|
|
(typing-action menu nil)))
|
|
|
|
(defmethod menu-prompt-line ((menu menu))
|
|
"If there is a prompt, show it:"
|
|
(menu-prompt menu))
|
|
|
|
(defun menu-prompt-visible (menu)
|
|
(or (menu-prompt menu)
|
|
(> (length (single-menu-current-input menu)) 0)))
|
|
|
|
(defmethod menu-prompt-line ((menu single-menu))
|
|
"When a prompt is shown, also show the search string."
|
|
(when (menu-prompt-visible menu)
|
|
(format nil "~@[~A ~]~A"
|
|
(menu-prompt menu) (single-menu-current-input menu))))
|
|
|
|
(defmethod typing-action ((menu menu) key-seq)
|
|
"Default action is to do nothing"
|
|
(declare (ignore key-seq)))
|
|
|
|
(defmethod typing-action ((menu single-menu) key-seq)
|
|
"If the user entered a key not mapped in @var{*menu-map}, check it.
|
|
If he's trying to type an entry's name, either complete or not based
|
|
on COMPLETE-PARTIAL. Match is case insensitive. If @var{key-seq} is nil,
|
|
some other function has manipulated the current-input and is requesting
|
|
a re-computation of the match."
|
|
(let ((input-char (and key-seq (get-input-char key-seq))))
|
|
(when input-char
|
|
(vector-push-extend input-char (single-menu-current-input menu)))
|
|
(handler-case
|
|
(when (or input-char (not key-seq))
|
|
(labels ((match-p (table-item)
|
|
(funcall (single-menu-filter-pred menu)
|
|
(car table-item)
|
|
(second table-item)
|
|
(single-menu-current-input menu))))
|
|
(setf (menu-table menu) (remove-if-not #'match-p (single-menu-unfiltered-table menu))
|
|
(menu-selected menu) 0)
|
|
(bound-check-menu menu)))
|
|
(cl-ppcre:ppcre-syntax-error ()))))
|
|
|
|
(defmethod typing-action ((menu batch-menu) key-seq)
|
|
"Mark the selected item with the character that was typed. If the character
|
|
is not allowed, as specified by allowed-markers, item is not marked"
|
|
(let ((input-char (and key-seq (get-input-char key-seq))))
|
|
(with-slots (selected table allowed-markers) menu
|
|
(when (and input-char (or (not allowed-markers) (member input-char allowed-markers)))
|
|
(setf (car (nth selected table)) input-char)
|
|
(menu-down menu)))))
|
|
|
|
(defun menu-element-name (element)
|
|
"Used for the default menus: they don't use menu-entry."
|
|
(if (listp element)
|
|
(first element)
|
|
element))
|
|
|
|
(defmethod get-menu-items ((menu menu))
|
|
(mapcar #'menu-element-name
|
|
(subseq (menu-table menu)
|
|
(menu-view-start menu) (menu-view-end menu))))
|
|
|
|
(defmethod get-menu-items ((menu batch-menu))
|
|
(with-slots (table view-start view-end) menu
|
|
(mapcar (lambda (entry)
|
|
(if (car entry)
|
|
;; if there is a mark, show it, else show a space
|
|
(concat (string (car entry)) (menu-entry-display (cdr entry)))
|
|
(concat " " (menu-entry-display (cdr entry)))))
|
|
(subseq table
|
|
view-start view-end))))
|
|
|
|
(defun menu-item-matches-regexp (item-string item-object user-input)
|
|
"The default filter predicate for SELECT-FROM-MENU. When using this
|
|
predicate, an item is visible when it matches all of the regular
|
|
expressions in USER-INPUT (multiple regexps are separated by one or
|
|
more spaces; ARGUMENT-POP is used to split the string)."
|
|
(declare (ignore item-object))
|
|
(match-all-regexps user-input item-string))
|
|
|
|
(defun run-menu (screen menu)
|
|
"Runs the menu. Implement all of the methods in the menu, then pass an instance to this function"
|
|
(declare (type menu menu))
|
|
;; align the menu, make the pages
|
|
(bound-check-menu menu)
|
|
(catch :menu-quit
|
|
(unwind-protect
|
|
(with-focus (screen-key-window screen)
|
|
(let ((*suppress-echo-timeout* t)
|
|
(displaying-help-bindings nil))
|
|
(loop
|
|
(let* ((sel (menu-selected menu))
|
|
(start (menu-view-start menu))
|
|
(end (menu-view-end menu))
|
|
(len (length (menu-table menu)))
|
|
(prompt-line (menu-prompt-line menu))
|
|
(strings (get-menu-items menu))
|
|
(highlight (- sel start)))
|
|
(unless displaying-help-bindings
|
|
(unless (zerop start)
|
|
(setf strings (cons "..." strings))
|
|
(incf highlight))
|
|
(unless (= len end)
|
|
(setf strings (nconc strings '("..."))))
|
|
(when prompt-line
|
|
(push prompt-line strings)
|
|
(incf highlight))
|
|
(run-hook-with-args *menu-selection-hook* menu)
|
|
(echo-string-list screen strings highlight)))
|
|
(multiple-value-bind (action key-seq) (read-from-keymap (menu-keymap menu))
|
|
(cond ((and action
|
|
(not (or (fboundp action)
|
|
(functionp action)))
|
|
(help-key-p key-seq))
|
|
(setf displaying-help-bindings t))
|
|
((and displaying-help-bindings
|
|
(eql action 'menu-abort))
|
|
(setf displaying-help-bindings nil))
|
|
(t
|
|
(when displaying-help-bindings
|
|
(setf displaying-help-bindings nil))
|
|
(if (fboundp action)
|
|
(progn (funcall action menu)
|
|
(bound-check-menu menu))
|
|
(typing-action menu (first key-seq)))))))))
|
|
(unmap-all-message-windows))))
|
|
|
|
|
|
(defun select-from-menu (screen table &optional (prompt "Search:")
|
|
(initial-selection 0)
|
|
extra-keymap
|
|
(filter-pred #'menu-item-matches-regexp))
|
|
"Prompt the user to select from a menu on SCREEN. TABLE can be
|
|
a list of values or a nested list. If it's a nested list, the first
|
|
element in the sublist is displayed in the menu. What is displayed
|
|
as menu items must be strings.
|
|
|
|
EXTRA-KEYMAP can be a keymap whose bindings will take precedence
|
|
over the default bindings.
|
|
|
|
FILTER-PRED should be a a function returning T when a certain menu
|
|
item should be visible to the user. It should accept arguments
|
|
|
|
ITEM-STRING (the string shown to the user), ITEM-OBJECT (the object
|
|
corresponding to the menu item), and USER-INPUT (the current user
|
|
input). The default is MENU-ITEM-MATCHES-REGEXP.
|
|
Returns the selected element in TABLE or nil if aborted. "
|
|
(check-type screen screen)
|
|
(check-type table (or (cons string) (cons cons)))
|
|
(check-type prompt (or null string))
|
|
(check-type initial-selection integer)
|
|
|
|
(when table
|
|
(let ((menu (make-instance 'single-menu
|
|
:table (if (every #'listp table)
|
|
table
|
|
(mapcar #'list table))
|
|
:selected initial-selection
|
|
:prompt prompt
|
|
:view-start 0
|
|
:view-end 0
|
|
:additional-keymap extra-keymap
|
|
:FILTER-PRED filter-pred)))
|
|
(run-menu screen menu))))
|
|
|
|
(defun select-from-batch-menu (screen table &key (prompt "Select:")
|
|
allowed-markers
|
|
(initial-selection 0)
|
|
extra-keymap)
|
|
"Prompt the user with a menu that allows them to mark each item
|
|
with a character. They can exit the menu by pressing enter, or
|
|
whatever key is mapped to 'menu-finish' in *menu-map*. Value returned
|
|
is an alist, where the cdr of each entry is a list of
|
|
items that were marked with that character. Note that the lisp printer cannot
|
|
distinguish between '(a . (b c d)) and '(a b c d).
|
|
|
|
Example when \"foo\" and \"bar\" are marked with '#\d', and \"baz\" is not marked:
|
|
((#\d \"foo\" \"bar\") (NIL \"baz\"))
|
|
ALLOWED-MARKERS is a list of characters. If this parameter is specified, no
|
|
other markers are allowed.
|
|
EXTRA-KEYMAP can be a keymap whose bindings will take precedence
|
|
over the default bindings."
|
|
(check-type screen screen)
|
|
(check-type table list)
|
|
(check-type prompt (or null string))
|
|
(check-type allowed-markers list)
|
|
(when table
|
|
(let ((menu (make-instance 'batch-menu
|
|
:table table
|
|
:prompt prompt
|
|
:allowed-markers allowed-markers
|
|
:selected initial-selection
|
|
:additional-keymap extra-keymap)))
|
|
(run-menu screen menu))))
|
|
|
|
(defun command-menu (screen items command-list &key (prompt "Select:")
|
|
(initial-selection 0)
|
|
extra-keymap)
|
|
"Use batch-menu to make selections and run commands specified in command-list.
|
|
|
|
SCREEN: The screen to display the menu on.
|
|
|
|
ITEMS: The items to be shown in the list. This is expected to be a list of @code{menu-item}s.
|
|
|
|
COMMAND-LIST: A list of entries defining the commands associated with each mark.
|
|
Only marks that are defined are allowed in the menu. The format
|
|
for these entries is (mark-character function calling-options).
|
|
|
|
Available calling-options:
|
|
:single (Default) Each value is passed separately to the supplied function.
|
|
:all all values selected with this mark are passed to the function in a list.
|
|
|
|
Example:
|
|
'((#\d 'delete-window) (#\m 'move-multiple-windows :all))"
|
|
(let ((results
|
|
(select-from-batch-menu screen items
|
|
:prompt prompt
|
|
;; use the first value of every entry
|
|
;; except when it is nill:
|
|
:allowed-markers (mapcan (lambda (x)
|
|
(if (first x)
|
|
(list (first x))))
|
|
command-list)
|
|
:initial-selection initial-selection
|
|
:extra-keymap extra-keymap)))
|
|
(dolist (command-entry command-list)
|
|
(let ((selections (assoc (first command-entry) results))
|
|
(func (second command-entry))
|
|
;; change this to cddr if we ever have more than one option?
|
|
(options (caddr command-entry)))
|
|
(when selections
|
|
(cond
|
|
((eql :all options)
|
|
(funcall func (mapcar 'menu-entry-data (cdr selections))))
|
|
;; default option: check if it is nil:
|
|
((or (eql options :all) (eql options nil))
|
|
(dolist (data (cdr selections))
|
|
(funcall func (menu-entry-data data))))
|
|
(t (error (format nil "keyword ~s not a valid command option for selection-menu."
|
|
options)))))))))
|
|
|
|
(when (null *menu-map*)
|
|
(setf *menu-map*
|
|
(let ((m (make-sparse-keymap)))
|
|
(define-key m (kbd "C-p") 'menu-up)
|
|
(define-key m (kbd "Up") 'menu-up)
|
|
(define-key m (kbd "S-Up") 'menu-scroll-up)
|
|
(define-key m (kbd "SunPageUp") 'menu-page-up)
|
|
|
|
(define-key m (kbd "C-n") 'menu-down)
|
|
(define-key m (kbd "Down") 'menu-down)
|
|
(define-key m (kbd "S-Down") 'menu-scroll-down)
|
|
(define-key m (kbd "SunPageDown") 'menu-page-down)
|
|
|
|
(define-key m (kbd "C-g") 'menu-abort)
|
|
(define-key m (kbd "ESC") 'menu-abort)
|
|
(define-key m (kbd "RET") 'menu-finish)
|
|
m)))
|
|
|
|
(when (null *single-menu-map*)
|
|
(setf *single-menu-map*
|
|
(let ((m (make-sparse-keymap)))
|
|
(define-key m (kbd "DEL") 'menu-backspace)
|
|
m)))
|
|
|
|
(when (null *batch-menu-map*)
|
|
(setf *batch-menu-map*
|
|
(let ((m (make-sparse-keymap)))
|
|
(define-key m (kbd "DEL") 'menu-backspace)
|
|
(define-key m (kbd "n") 'menu-down)
|
|
(define-key m (kbd "p") 'menu-up)
|
|
(define-key m (kbd "space") 'menu-down)
|
|
(define-key m (kbd "u") (lambda (menu)
|
|
(batch-menu-unmark-selected menu)
|
|
(menu-down menu)))
|
|
(define-key m (kbd "x") 'menu-finish)
|
|
m)))
|