File: menu.lisp

package info (click to toggle)
stumpwm 2:1.0.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 1,216 kB
  • sloc: lisp: 13,721; makefile: 180; sh: 30
file content (251 lines) | stat: -rw-r--r-- 10,079 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
;; Copyright (C) 2008 Shawn Betts
;;
;;  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.
;;
;; Code:

;;; interactive menu

(in-package #:stumpwm)

(export '(select-from-menu
          menu-state-selected
          menu-state-table))

(defvar *menu-map* nil
  "The keymap used by the interactive menu.")

(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 "DEL") 'menu-backspace)

          (define-key m (kbd "C-g") 'menu-abort)
          (define-key m (kbd "ESC") 'menu-abort)
          (define-key m (kbd "RET") 'menu-finish)
          m)))

(defstruct menu-state
  unfiltered-table table filter-pred prompt selected view-start view-end
  (current-input (make-array 10 :element-type 'character :adjustable t :fill-pointer 0)))

(defun menu-scrolling-required (menu)
  (and *menu-maximum-height*
       (> (length (menu-state-table menu))
          *menu-maximum-height*)))

(defun menu-height (menu)
  (let ((len (length (menu-state-table menu))))
    (min (or *menu-maximum-height* len) len)))

(defun menu-prompt-visible (menu)
  (or (menu-state-prompt menu)
      (> (length (menu-state-current-input menu)) 0)))

(defun bound-check-menu (menu)
  "Adjust the menu view and selected item based
on current view and new selection."
  (let ((len (length (menu-state-table menu))))
    ;; Wrap around
    (setf (menu-state-selected menu)
          (cond ((< (menu-state-selected menu) 0) (1- len))
                ((>= (menu-state-selected menu) len) 0)
                (t (menu-state-selected menu))))
    (setf (values (menu-state-view-start menu)
                  (menu-state-view-end menu))
          (if (zerop len)
              (values 0 0)
              (let* ((menu-height (menu-height menu))
                     (sel (menu-state-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)))))))

(defun menu-up (menu)
  (setf (fill-pointer (menu-state-current-input menu)) 0)
  (decf (menu-state-selected menu))
  (bound-check-menu menu))

(defun menu-down (menu)
  (setf (fill-pointer (menu-state-current-input menu)) 0)
  (incf (menu-state-selected menu))
  (bound-check-menu menu))

(defun menu-scroll-up (menu)
  (setf (fill-pointer (menu-state-current-input menu)) 0)
  (decf (menu-state-selected menu) *menu-scrolling-step*)
  (bound-check-menu menu))

(defun menu-scroll-down (menu)
  (setf (fill-pointer (menu-state-current-input menu)) 0)
  (incf (menu-state-selected menu) *menu-scrolling-step*)
  (bound-check-menu menu))

(defun menu-page-up (menu)
  (when *menu-maximum-height* ;;No scrolling = no page up/down
    (setf (fill-pointer (menu-state-current-input menu)) 0)
    (decf (menu-state-selected menu) *menu-maximum-height*)
    (let ((*menu-scrolling-step* *menu-maximum-height*))
      (bound-check-menu menu))))

(defun menu-page-down (menu)
  (when *menu-maximum-height*
    (setf (fill-pointer (menu-state-current-input menu)) 0)
    (incf (menu-state-selected menu) *menu-maximum-height*)
    (let ((*menu-scrolling-step* *menu-maximum-height*))
      (bound-check-menu menu))))


(defun menu-finish (menu)
  (throw :menu-quit (nth (menu-state-selected menu) (menu-state-table menu))))

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

(defun menu-element-name (element)
  (if (listp element)
      (first element)
      element))

(defun menu-backspace (menu)
  (when (> (fill-pointer (menu-state-current-input menu)) 0)
    (vector-pop (menu-state-current-input menu))
    (check-menu-complete menu nil)))

(defun check-menu-complete (menu key-seq)
  "If the user entered a key not mapped in @var{*menu-map}, check if
  he's trying to type an entry's name. 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 (menu-state-current-input menu)))
    (handler-case
        (when (or input-char (not key-seq))
          (labels ((match-p (table-item)
                     (funcall (menu-state-filter-pred menu)
                              (car table-item)
                              (second table-item)
                              (menu-state-current-input menu))))
            (setf (menu-state-table menu) (remove-if-not #'match-p (menu-state-unfiltered-table menu))
                  (menu-state-selected menu) 0)
            (bound-check-menu menu)))
      (cl-ppcre:ppcre-syntax-error ()))))

(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)."
  (match-all-regexps user-input item-string))

(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 an alist. If it's an alist, the CAR of each
element 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 list)
  (check-type prompt (or null string))
  (check-type initial-selection integer)

  (when table
    (let* ((*record-last-msg-override* t)
           (*suppress-echo-timeout* t)
           (menu (make-menu-state
                  :unfiltered-table table
                  :table table
                  :filter-pred filter-pred
                  :prompt prompt
                  :view-start 0
                  :view-end 0
                  :selected initial-selection))
           (keymap (if extra-keymap
                       (list extra-keymap *menu-map*)
                       (list *menu-map*))))
      (bound-check-menu menu)
      (catch :menu-quit
        (unwind-protect
             (with-focus (screen-key-window screen)
               (loop
                  (let* ((sel (menu-state-selected menu))
                         (start (menu-state-view-start menu))
                         (end (menu-state-view-end menu))
                         (len (length (menu-state-table menu)))
                         (prompt-line (when (menu-prompt-visible menu)
                                        (format nil "~@[~A ~]~A"
                                                prompt (menu-state-current-input menu))))
                         (strings (mapcar #'menu-element-name
                                          (subseq (menu-state-table menu)
                                                  start end)))
                         (highlight (- sel start)))
                    (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))
                    (echo-string-list screen strings highlight))
                  (multiple-value-bind (action key-seq) (read-from-keymap keymap)
                    (if action
                        (progn (funcall action menu)
                               (bound-check-menu menu))
                        (check-menu-complete menu (first key-seq))))))
          (unmap-all-message-windows))))))