mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-21 7074318d7ab58aca124f590c42fd820e8eb258a5
commit | author | age
5cb5f7 1 ;;; popup.el --- Visual Popup User Interface
C 2
3 ;; Copyright (C) 2009-2015  Tomohiro Matsuyama
4
5 ;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com>
6 ;; Keywords: lisp
7 ;; Package-Version: 20160709.1429
8 ;; Version: 0.5.3
9 ;; Package-Requires: ((cl-lib "0.5"))
10
11 ;; This program is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; popup.el is a visual popup user interface library for Emacs. This
27 ;; provides a basic API and common UI widgets such as popup tooltips
28 ;; and popup menus.
29 ;; See README.markdown for more information.
30
31 ;;; Code:
32
33 (require 'cl-lib)
34
35 (defconst popup-version "0.5.3")
36
37
38
39 ;;; Utilities
40
41 (defun popup-calculate-max-width (max-width)
42   "Determines whether the width desired is
43 character or window proportion based, And returns the result."
44   (cl-typecase max-width
45     (integer max-width)
46     (float (* (ceiling (/ (round (* max-width (window-width))) 10.0)) 10))))
47
48 (defvar popup-use-optimized-column-computation t
49   "Use the optimized column computation routine.
50 If there is a problem, please set it nil.")
51
52 (defmacro popup-aif (test then &rest else)
53   "Anaphoric if."
54   (declare (indent 2))
55   `(let ((it ,test))
56      (if it ,then ,@else)))
57
58 (defmacro popup-awhen (test &rest body)
59   "Anaphoric when."
60   (declare (indent 1))
61   `(let ((it ,test))
62      (when it ,@body)))
63
64 (defun popup-x-to-string (x)
65   "Convert any object to string effeciently.
66 This is faster than `prin1-to-string' in many cases."
67   (cl-typecase x
68     (string x)
69     (symbol (symbol-name x))
70     (integer (number-to-string x))
71     (float (number-to-string x))
72     (t (format "%s" x))))
73
74 (defun popup-substring-by-width (string width)
75   "Return a cons cell of substring and remaining string by
76 splitting with WIDTH."
77   ;; Expand tabs into 4 spaces
78   (setq string (replace-regexp-in-string "\t" "    " string))
79   (cl-loop with len = (length string)
80            with w = 0
81            for l from 0
82            for c in (append string nil)
83            while (<= (cl-incf w (char-width c)) width)
84            finally return
85            (if (< l len)
86                (cons (substring string 0 l) (substring string l))
87              (list string))))
88
89 (defun popup-fill-string (string &optional width max-width justify squeeze)
90   "Split STRING into fixed width strings and return a cons cell
91 like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual
92 maxim width of ROWS.
93
94 The argument WIDTH specifies the width of filling each
95 paragraph. WIDTH nil means don't perform any justification and
96 word wrap. Note that this function doesn't add any padding
97 characters at the end of each row.
98
99 MAX-WIDTH, if WIDTH is nil, specifies the maximum number of
100 columns.
101
102 The optional fourth argument JUSTIFY specifies which kind of
103 justification to do: `full', `left', `right', `center', or
104 `none' (equivalent to nil).  A value of t means handle each
105 paragraph as specified by its text properties.
106
107 SQUEEZE nil means leave whitespaces other than line breaks
108 untouched."
109   (if (eq width 0)
110       (error "Can't fill string with 0 width"))
111   (if width
112       (setq max-width width))
113   (with-temp-buffer
114     (let ((tab-width 4)
115           (fill-column width)
116           (left-margin 0)
117           (kinsoku-limit 1)
118           indent-tabs-mode
119           row rows)
120       (insert string)
121       (untabify (point-min) (point-max))
122       (if width
123           (fill-region (point-min) (point-max) justify (not squeeze)))
124       (goto-char (point-min))
125       (setq width 0)
126       (while (prog2
127                  (let ((line (buffer-substring
128                               (point) (progn (end-of-line) (point)))))
129                    (if max-width
130                        (while (progn
131                                 (setq row (truncate-string-to-width line max-width)
132                                       width (max width (string-width row)))
133                                 (push row rows)
134                                 (if (not (= (length row) (length line)))
135                                     (setq line (substring line (length row))))))
136                      (setq width (max width (string-width line)))
137                      (push line rows)))
138                  (< (point) (point-max))
139                (beginning-of-line 2)))
140       (cons width (nreverse rows)))))
141
142 (defmacro popup-save-buffer-state (&rest body)
143   (declare (indent 0))
144   `(save-excursion
145      (let ((buffer-undo-list t)
146            (inhibit-read-only t)
147            (modified (buffer-modified-p)))
148        (unwind-protect
149            (progn ,@body)
150          (set-buffer-modified-p modified)))))
151
152 (defun popup-vertical-motion (column direction)
153   "A portable version of `vertical-motion'."
154   (if (>= emacs-major-version 23)
155       (vertical-motion (cons column direction))
156     (vertical-motion direction)
157     (move-to-column (+ (current-column) column))))
158
159 (defun popup-last-line-of-buffer-p ()
160   "Return non-nil if the cursor is at the last line of the
161 buffer."
162   (save-excursion (end-of-line) (/= (forward-line) 0)))
163
164 (defun popup-lookup-key-by-event (function event)
165   (or (funcall function (vector event))
166       (if (symbolp event)
167           (popup-aif (get event 'event-symbol-element-mask)
168               (funcall function
169                        (vector (logior (or (get (car it) 'ascii-character)
170                                            0)
171                                        (cadr it))))))))
172
173
174
175 ;;; Core
176
177 (defgroup popup nil
178   "Visual Popup User Interface"
179   :group 'lisp
180   :prefix "popup-")
181
182 (defface popup-face
183   '((t (:inherit default :background "lightgray" :foreground "black")))
184   "Face for popup."
185   :group 'popup)
186
187 (defface popup-summary-face
188   '((t (:inherit popup-face :foreground "dimgray")))
189   "Face for popup summary."
190   :group 'popup)
191
192 (defface popup-scroll-bar-foreground-face
193   '((t (:background "black")))
194   "Foreground face for scroll-bar."
195   :group 'popup)
196
197 (defface popup-scroll-bar-background-face
198   '((t (:background "gray")))
199   "Background face for scroll-bar."
200   :group 'popup)
201
202 (defvar popup-instances nil
203   "Popup instances.")
204
205 (defvar popup-scroll-bar-foreground-char
206   (propertize " " 'face 'popup-scroll-bar-foreground-face)
207   "Foreground character for scroll-bar.")
208
209 (defvar popup-scroll-bar-background-char
210   (propertize " " 'face 'popup-scroll-bar-background-face)
211   "Background character for scroll-bar.")
212
213 (cl-defstruct popup
214   point row column width height min-height direction overlays keymap
215   parent depth
216   face mouse-face selection-face summary-face
217   margin-left margin-right margin-left-cancel scroll-bar symbol
218   cursor offset scroll-top current-height list newlines
219   pattern original-list invis-overlays)
220
221 (defun popup-item-propertize (item &rest properties)
222   "Same as `propertize' except that this avoids overriding
223 existed value with `nil' property."
224   (cl-loop for (k v) on properties by 'cddr
225            if v append (list k v) into props
226            finally return
227            (apply 'propertize
228                   (popup-x-to-string item)
229                   props)))
230
231 (defun popup-item-property (item property)
232   "Same as `get-text-property' except that this returns nil if
233 ITEM is not string."
234   (if (stringp item)
235       (get-text-property 0 property item)))
236
237 (cl-defun popup-make-item (name
238                            &key
239                            value
240                            face
241                            mouse-face
242                            selection-face
243                            sublist
244                            document
245                            symbol
246                            summary)
247   "Utility function to make popup item. See also
248 `popup-item-propertize'."
249   (popup-item-propertize name
250                          'value value
251                          'popup-face face
252                          'popup-mouse-face mouse-face
253                          'selection-face selection-face
254                          'document document
255                          'symbol symbol
256                          'summary summary
257                          'sublist sublist))
258
259 (defsubst popup-item-value (item)               (popup-item-property item 'value))
260 (defsubst popup-item-value-or-self (item)       (or (popup-item-value item) item))
261 (defsubst popup-item-face (item)                (popup-item-property item 'popup-face))
262 (defsubst popup-item-mouse-face (item)          (popup-item-property item 'popup-mouse-face))
263 (defsubst popup-item-selection-face (item)      (popup-item-property item 'selection-face))
264 (defsubst popup-item-document (item)            (popup-item-property item 'document))
265 (defsubst popup-item-summary (item)             (popup-item-property item 'summary))
266 (defsubst popup-item-symbol (item)              (popup-item-property item 'symbol))
267 (defsubst popup-item-sublist (item)             (popup-item-property item 'sublist))
268
269 (defun popup-item-documentation (item)
270   (let ((doc (popup-item-document item)))
271     (if (functionp doc)
272         (setq doc (funcall doc (popup-item-value-or-self item))))
273     doc))
274
275 (defun popup-item-show-help-1 (item)
276   (let ((doc (popup-item-documentation item)))
277     (when doc
278       (with-current-buffer (get-buffer-create " *Popup Help*")
279         (erase-buffer)
280         (insert doc)
281         (goto-char (point-min))
282         (display-buffer (current-buffer)))
283       t)))
284
285 (defun popup-item-show-help-with-event-loop (item)
286   (save-window-excursion
287     (when (popup-item-show-help-1 item)
288       (cl-loop do (clear-this-command-keys)
289                for key = (read-key-sequence-vector nil)
290                do
291                (cl-case (key-binding key)
292                  (scroll-other-window
293                   (scroll-other-window))
294                  (scroll-other-window-down
295                   (scroll-other-window-down nil))
296                  (otherwise
297                   (setq unread-command-events (append key unread-command-events))
298                   (cl-return)))))))
299
300 (defun popup-item-show-help (item &optional persist)
301   "Display the documentation of ITEM with `display-buffer'. If
302 PERSIST is nil, the documentation buffer will be closed
303 automatically, meaning interal event loop ensures the buffer to
304 be closed. Otherwise, the buffer will be just displayed as
305 usual."
306   (when item
307     (if (not persist)
308         (popup-item-show-help-with-event-loop item)
309       (popup-item-show-help-1 item))))
310
311 (defun popup-set-list (popup list)
312   (popup-set-filtered-list popup list)
313   (setf (popup-pattern popup) nil)
314   (setf (popup-original-list popup) list))
315
316 (defun popup-set-filtered-list (popup list)
317   (let ((offset
318          (if (> (popup-direction popup) 0)
319              0
320            (max (- (popup-height popup) (length list)) 0))))
321     (setf (popup-list popup) list
322           (popup-offset popup) offset)))
323
324 (defun popup-selected-item (popup)
325   (nth (popup-cursor popup) (popup-list popup)))
326
327 (defun popup-selected-line (popup)
328   (- (popup-cursor popup) (popup-scroll-top popup)))
329
330 (defun popup-line-overlay (popup line)
331   (aref (popup-overlays popup) line))
332
333 (defun popup-selected-line-overlay (popup)
334   (popup-line-overlay popup (popup-selected-line popup)))
335
336 (defun popup-hide-line (popup line)
337   (let ((overlay (popup-line-overlay popup line)))
338     (overlay-put overlay 'display nil)
339     (overlay-put overlay 'after-string nil)))
340
341 (defun popup-line-hidden-p (popup line)
342   (let ((overlay (popup-line-overlay popup line)))
343     (and (eq (overlay-get overlay 'display) nil)
344          (eq (overlay-get overlay 'after-string) nil))))
345
346 (cl-defun popup-set-line-item (popup
347                                line
348                                &key
349                                item
350                                face
351                                mouse-face
352                                margin-left
353                                margin-right
354                                scroll-bar-char
355                                symbol
356                                summary
357                                summary-face
358                                keymap)
359   (let* ((overlay (popup-line-overlay popup line))
360          (content (popup-create-line-string popup (popup-x-to-string item)
361                                             :margin-left margin-left
362                                             :margin-right margin-right
363                                             :symbol symbol
364                                             :summary summary
365                                             :summary-face summary-face))
366          (start 0)
367          (prefix (overlay-get overlay 'prefix))
368          (postfix (overlay-get overlay 'postfix))
369          end)
370     (put-text-property 0 (length content) 'popup-item item content)
371     (put-text-property 0 (length content) 'keymap keymap content)
372     ;; Overlap face properties
373     (when (get-text-property start 'face content)
374       (setq start (next-single-property-change start 'face content)))
375     (while (and start (setq end (next-single-property-change start 'face content)))
376       (put-text-property start end 'face face content)
377       (setq start (next-single-property-change end 'face content)))
378     (when start
379       (put-text-property start (length content) 'face face content))
380     (when mouse-face
381       (put-text-property 0 (length content) 'mouse-face mouse-face content))
382     (let ((prop (if (overlay-get overlay 'dangle)
383                     'after-string
384                   'display)))
385       (overlay-put overlay
386                    prop
387                    (concat prefix
388                            content
389                            scroll-bar-char
390                            postfix)))))
391
392 (cl-defun popup-create-line-string (popup
393                                     string
394                                     &key
395                                     margin-left
396                                     margin-right
397                                     symbol
398                                     summary
399                                     summary-face)
400   (let* ((popup-width (popup-width popup))
401          (summary-width (string-width summary))
402          (content-width (max
403                          (min popup-width (string-width string))
404                          (- popup-width
405                             (if (> summary-width 0)
406                                 (+ summary-width 2)
407                               0))))
408          (string (car (popup-substring-by-width string content-width)))
409          (string-width (string-width string))
410          (spacing (max (- popup-width string-width summary-width)
411                        (if (> popup-width string-width) 1 0)))
412          (truncated-summary
413           (car (popup-substring-by-width
414                 summary (max (- popup-width string-width spacing) 0)))))
415     (when summary-face
416       (put-text-property 0 (length truncated-summary)
417                          'face summary-face truncated-summary))
418     (concat margin-left
419             string
420             (make-string spacing ? )
421             truncated-summary
422             symbol
423             margin-right)))
424
425 (defun popup-live-p (popup)
426   "Return non-nil if POPUP is alive."
427   (and popup (popup-overlays popup) t))
428
429 (defun popup-child-point (popup &optional offset)
430   (overlay-end
431    (popup-line-overlay
432     popup
433     (or offset
434         (popup-selected-line popup)))))
435
436 (defun popup-calculate-direction (height row)
437   "Return a proper direction when displaying a popup on this
438 window. HEIGHT is the a height of the popup, and ROW is a line
439 number at the point."
440   (let* ((remaining-rows (- (max 1 (- (window-height)
441                                       (if mode-line-format 1 0)
442                                       (if header-line-format 1 0)))
443                             (count-lines (window-start) (point))))
444          (enough-space-above (> row height))
445          (enough-space-below (<= height remaining-rows)))
446     (if (and enough-space-above
447              (not enough-space-below))
448         -1
449       1)))
450
451 (cl-defun popup-create (point
452                         width
453                         height
454                         &key
455                         min-height
456                         max-width
457                         around
458                         (face 'popup-face)
459                         mouse-face
460                         (selection-face face)
461                         (summary-face 'popup-summary-face)
462                         scroll-bar
463                         margin-left
464                         margin-right
465                         symbol
466                         parent
467                         parent-offset
468                         keymap)
469   "Create a popup instance at POINT with WIDTH and HEIGHT.
470
471 MIN-HEIGHT is a minimal height of the popup. The default value is
472 0.
473
474 MAX-WIDTH is the maximum width of the popup. The default value is
475 nil (no limit). If a floating point, the value refers to the ratio of
476 the window. If an integer, limit is in characters.
477
478 If AROUND is non-nil, the popup will be displayed around the
479 point but not at the point.
480
481 FACE is a background face of the popup. The default value is POPUP-FACE.
482
483 SELECTION-FACE is a foreground (selection) face of the popup The
484 default value is POPUP-FACE.
485
486 If SCROLL-BAR is non-nil, the popup will have a scroll bar at the
487 right.
488
489 If MARGIN-LEFT is non-nil, the popup will have a margin at the
490 left.
491
492 If MARGIN-RIGHT is non-nil, the popup will have a margin at the
493 right.
494
495 SYMBOL is a single character which indicates a kind of the item.
496
497 PARENT is a parent popup instance. If PARENT is omitted, the
498 popup will be a root instance.
499
500 PARENT-OFFSET is a row offset from the parent popup.
501
502 KEYMAP is a keymap that will be put on the popup contents."
503   (or margin-left (setq margin-left 0))
504   (or margin-right (setq margin-right 0))
505   (unless point
506     (setq point
507           (if parent (popup-child-point parent parent-offset) (point))))
508   (when max-width
509     (setq width (min width (popup-calculate-max-width max-width))))
510   (save-excursion
511     (goto-char point)
512     (let* ((col-row (posn-col-row (posn-at-point)))
513            (row (cdr col-row))
514            (column (car col-row))
515            (overlays (make-vector height nil))
516            (popup-width (+ width
517                            (if scroll-bar 1 0)
518                            margin-left
519                            margin-right
520                            (if symbol 2 0)))
521            margin-left-cancel
522            (window (selected-window))
523            (window-start (window-start))
524            (window-hscroll (window-hscroll))
525            (window-width (window-width))
526            (right (+ column popup-width))
527            (overflow (and (> right window-width)
528                           (>= right popup-width)))
529            (foldable (and (null parent)
530                           (>= column popup-width)))
531            (direction (or
532                        ;; Currently the direction of cascade popup won't be changed
533                        (and parent (popup-direction parent))
534
535                        ;; Calculate direction
536                        (popup-calculate-direction height row)))
537            (depth (if parent (1+ (popup-depth parent)) 0))
538            (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0))))
539            invis-overlays
540            current-column)
541       ;; Case: no newlines at the end of the buffer
542       (when (> newlines 0)
543         (popup-save-buffer-state
544           (goto-char (point-max))
545           (insert (make-string newlines ?\n))))
546
547       ;; Case: the popup overflows
548       (if overflow
549           (if foldable
550               (progn
551                 (cl-decf column (- popup-width margin-left margin-right))
552                 (unless around (move-to-column column)))
553             (when (not truncate-lines)
554               ;; Truncate.
555               (let ((d (1+ (- popup-width (- window-width column)))))
556                 (cl-decf popup-width d)
557                 (cl-decf width d)))
558             (cl-decf column margin-left))
559         (cl-decf column margin-left))
560
561       ;; Case: no space at the left
562       (when (and (null parent)
563                  (< column 0))
564         ;; Cancel margin left
565         (setq column 0)
566         (cl-decf popup-width margin-left)
567         (setq margin-left-cancel t))
568
569       (dotimes (i height)
570         (let (overlay begin w (dangle t) (prefix "") (postfix ""))
571           (when around
572             (popup-vertical-motion column direction))
573           (cl-loop for ov in (overlays-in (save-excursion
574                                             (beginning-of-visual-line)
575                                             (point))
576                                           (save-excursion
577                                             (end-of-visual-line)
578                                             (point)))
579                    when (and (not (overlay-get ov 'popup))
580                              (not (overlay-get ov 'popup-item))
581                              (or (overlay-get ov 'invisible)
582                                  (overlay-get ov 'display)))
583                    do (progn
584                         (push (list ov (overlay-get ov 'display)) invis-overlays)
585                         (overlay-put ov 'display "")))
586           (setq around t)
587           (setq current-column (car (posn-col-row (posn-at-point))))
588
589           (when (< current-column column)
590             ;; Extend short buffer lines by popup prefix (line of spaces)
591             (setq prefix (make-string
592                           (+ (if (= current-column 0)
593                                  (- window-hscroll current-column)
594                                0)
595                              (- column current-column))
596                           ? )))
597
598           (setq begin (point))
599           (setq w (+ popup-width (length prefix)))
600           (while (and (not (eolp)) (> w 0))
601             (setq dangle nil)
602             (cl-decf w (char-width (char-after)))
603             (forward-char))
604           (if (< w 0)
605               (setq postfix (make-string (- w) ? )))
606
607           (setq overlay (make-overlay begin (point)))
608           (overlay-put overlay 'popup t)
609           (overlay-put overlay 'window window)
610           (overlay-put overlay 'dangle dangle)
611           (overlay-put overlay 'prefix prefix)
612           (overlay-put overlay 'postfix postfix)
613           (overlay-put overlay 'width width)
614           (aset overlays
615                 (if (> direction 0) i (- height i 1))
616                 overlay)))
617       (cl-loop for p from (- 10000 (* depth 1000))
618                for overlay in (nreverse (append overlays nil))
619                do (overlay-put overlay 'priority p))
620       (let ((it (make-popup :point point
621                             :row row
622                             :column column
623                             :width width
624                             :height height
625                             :min-height min-height
626                             :direction direction
627                             :parent parent
628                             :depth depth
629                             :face face
630                             :mouse-face mouse-face
631                             :selection-face selection-face
632                             :summary-face summary-face
633                             :margin-left margin-left
634                             :margin-right margin-right
635                             :margin-left-cancel margin-left-cancel
636                             :scroll-bar scroll-bar
637                             :symbol symbol
638                             :cursor 0
639                             :offset 0
640                             :scroll-top 0
641                             :current-height 0
642                             :list nil
643                             :newlines newlines
644                             :overlays overlays
645                             :invis-overlays invis-overlays
646                             :keymap keymap)))
647         (push it popup-instances)
648         it))))
649
650 (defun popup-delete (popup)
651   "Delete POPUP instance."
652   (when (popup-live-p popup)
653     (popup-hide popup)
654     (mapc 'delete-overlay (popup-overlays popup))
655     (setf (popup-overlays popup) nil)
656     (setq popup-instances (delq popup popup-instances))
657     ;; Restore newlines state
658     (let ((newlines (popup-newlines popup)))
659       (when (> newlines 0)
660         (popup-save-buffer-state
661           (goto-char (point-max))
662           (dotimes (i newlines)
663             (if (and (char-before)
664                      (= (char-before) ?\n))
665                 (delete-char -1)))))))
666   nil)
667
668 (defun popup-draw (popup)
669   "Draw POPUP."
670   (cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
671            do (overlay-put ov 'display ""))
672
673   (cl-loop with height = (popup-height popup)
674            with min-height = (popup-min-height popup)
675            with popup-face = (popup-face popup)
676            with mouse-face = (popup-mouse-face popup)
677            with selection-face = (popup-selection-face popup)
678            with summary-face-0 = (popup-summary-face popup)
679            with list = (popup-list popup)
680            with length = (length list)
681            with thum-size = (max (/ (* height height) (max length 1)) 1)
682            with page-size = (/ (+ 0.0 (max length 1)) height)
683            with scroll-bar = (popup-scroll-bar popup)
684            with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? )
685            with margin-right = (make-string (popup-margin-right popup) ? )
686            with symbol = (popup-symbol popup)
687            with cursor = (popup-cursor popup)
688            with scroll-top = (popup-scroll-top popup)
689            with offset = (popup-offset popup)
690            with keymap = (popup-keymap popup)
691            for o from offset
692            for i from scroll-top
693            while (< o height)
694            for item in (nthcdr scroll-top list)
695            for page-index = (* thum-size (/ o thum-size))
696            for face = (if (= i cursor)
697                           (or (popup-item-selection-face item) selection-face)
698                         (or (popup-item-face item) popup-face))
699            for summary-face = (unless (= i cursor) summary-face-0)
700            for empty-char = (propertize " " 'face face)
701            for scroll-bar-char = (if scroll-bar
702                                      (cond
703                                       ((and (not (eq scroll-bar :always))
704                                             (<= page-size 1))
705                                        empty-char)
706                                       ((and (> page-size 1)
707                                             (>= cursor (* page-index page-size))
708                                             (< cursor (* (+ page-index thum-size) page-size)))
709                                        popup-scroll-bar-foreground-char)
710                                       (t
711                                        popup-scroll-bar-background-char))
712                                    "")
713            for sym = (if symbol
714                          (concat " " (or (popup-item-symbol item) " "))
715                        "")
716            for summary = (or (popup-item-summary item) "")
717
718            do
719            ;; Show line and set item to the line
720            (popup-set-line-item popup o
721                                 :item item
722                                 :face face
723                                 :mouse-face mouse-face
724                                 :margin-left margin-left
725                                 :margin-right margin-right
726                                 :scroll-bar-char scroll-bar-char
727                                 :symbol sym
728                                 :summary summary
729                                 :summary-face summary-face
730                                 :keymap keymap)
731
732            finally
733            ;; Remember current height
734            (setf (popup-current-height popup) (- o offset))
735
736            ;; Hide remaining lines
737            (let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) ""))
738                  (symbol (if symbol " " "")))
739              (if (> (popup-direction popup) 0)
740                  (progn
741                    (when min-height
742                      (while (< o min-height)
743                        (popup-set-line-item popup o
744                                             :item ""
745                                             :face popup-face
746                                             :margin-left margin-left
747                                             :margin-right margin-right
748                                             :scroll-bar-char scroll-bar-char
749                                             :symbol symbol
750                                             :summary "")
751                        (cl-incf o)))
752                    (while (< o height)
753                      (popup-hide-line popup o)
754                      (cl-incf o)))
755                (cl-loop with h = (if min-height (- height min-height) offset)
756                         for o from 0 below offset
757                         if (< o h)
758                         do (popup-hide-line popup o)
759                         if (>= o h)
760                         do (popup-set-line-item popup o
761                                                 :item ""
762                                                 :face popup-face
763                                                 :margin-left margin-left
764                                                 :margin-right margin-right
765                                                 :scroll-bar-char scroll-bar-char
766                                                 :symbol symbol
767                                                 :summary ""))))))
768
769 (defun popup-hide (popup)
770   "Hide POPUP."
771   (cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
772            do (overlay-put ov 'display olddisplay))
773   (dotimes (i (popup-height popup))
774     (popup-hide-line popup i)))
775
776 (defun popup-hidden-p (popup)
777   "Return non-nil if POPUP is hidden."
778   (let ((hidden t))
779     (when (popup-live-p popup)
780       (dotimes (i (popup-height popup))
781         (unless (popup-line-hidden-p popup i)
782           (setq hidden nil))))
783     hidden))
784
785 (defun popup-jump (popup cursor)
786   "Jump to a position specified by CURSOR of POPUP and draw."
787   (let ((scroll-top (popup-scroll-top popup)))
788     ;; Do not change page as much as possible.
789     (unless (and (<= scroll-top cursor)
790                  (< cursor (+ scroll-top (popup-height popup))))
791       (setf (popup-scroll-top popup) cursor))
792     (setf (popup-cursor popup) cursor)
793     (popup-draw popup)))
794
795 (defun popup-select (popup i)
796   "Select the item at I of POPUP and draw."
797   (setq i (+ i (popup-offset popup)))
798   (when (and (<= 0 i) (< i (popup-height popup)))
799     (setf (popup-cursor popup) i)
800     (popup-draw popup)
801     t))
802
803 (defun popup-next (popup)
804   "Select the next item of POPUP and draw."
805   (let ((height (popup-height popup))
806         (cursor (1+ (popup-cursor popup)))
807         (scroll-top (popup-scroll-top popup))
808         (length (length (popup-list popup))))
809     (cond
810      ((>= cursor length)
811       ;; Back to first page
812       (setq cursor 0
813             scroll-top 0))
814      ((= cursor (+ scroll-top height))
815       ;; Go to next page
816       (setq scroll-top (min (1+ scroll-top) (max (- length height) 0)))))
817     (setf (popup-cursor popup) cursor
818           (popup-scroll-top popup) scroll-top)
819     (popup-draw popup)))
820
821 (defun popup-previous (popup)
822   "Select the previous item of POPUP and draw."
823   (let ((height (popup-height popup))
824         (cursor (1- (popup-cursor popup)))
825         (scroll-top (popup-scroll-top popup))
826         (length (length (popup-list popup))))
827     (cond
828      ((< cursor 0)
829       ;; Go to last page
830       (setq cursor (1- length)
831             scroll-top (max (- length height) 0)))
832      ((= cursor (1- scroll-top))
833       ;; Go to previous page
834       (cl-decf scroll-top)))
835     (setf (popup-cursor popup) cursor
836           (popup-scroll-top popup) scroll-top)
837     (popup-draw popup)))
838
839 (defun popup-page-next (popup)
840   "Select next item of POPUP per `popup-height' range.
841 Pages down through POPUP."
842   (dotimes (counter (1- (popup-height popup)))
843     (popup-next popup)))
844
845 (defun popup-page-previous (popup)
846   "Select previous item of POPUP per `popup-height' range.
847 Pages up through POPUP."
848   (dotimes (counter (1- (popup-height popup)))
849     (popup-previous popup)))
850
851 (defun popup-scroll-down (popup &optional n)
852   "Scroll down N of POPUP and draw."
853   (let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1))
854                          (- (length (popup-list popup)) (popup-height popup)))))
855     (setf (popup-cursor popup) scroll-top
856           (popup-scroll-top popup) scroll-top)
857     (popup-draw popup)))
858
859 (defun popup-scroll-up (popup &optional n)
860   "Scroll up N of POPUP and draw."
861   (let ((scroll-top (max (- (popup-scroll-top popup) (or n 1))
862                          0)))
863     (setf (popup-cursor popup) scroll-top
864           (popup-scroll-top popup) scroll-top)
865     (popup-draw popup)))
866
867
868
869 ;;; Popup Incremental Search
870
871 (defface popup-isearch-match
872   '((t (:inherit default :background "sky blue")))
873   "Popup isearch match face."
874   :group 'popup)
875
876 (defvar popup-isearch-cursor-color "blue")
877
878 (defvar popup-isearch-keymap
879   (let ((map (make-sparse-keymap)))
880     ;(define-key map "\r"        'popup-isearch-done)
881     (define-key map "\C-g"      'popup-isearch-cancel)
882     (define-key map "\C-b"      'popup-isearch-close)
883     (define-key map [left]      'popup-isearch-close)
884     (define-key map "\C-h"      'popup-isearch-delete)
885     (define-key map (kbd "DEL") 'popup-isearch-delete)
886     (define-key map (kbd "C-y") 'popup-isearch-yank)
887     map))
888
889 (defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help
890   "Function used for showing quick help by `popup-menu*'.")
891
892 (defcustom popup-isearch-regexp-builder-function #'regexp-quote
893   "Function used to construct a regexp from a pattern. You may for instance
894   provide a function that replaces spaces by '.+' if you like helm or ivy style
895   of completion."
896   :type 'function)
897
898 (defsubst popup-isearch-char-p (char)
899   (and (integerp char)
900        (<= 32 char)
901        (<= char 126)))
902
903 (defun popup-isearch-filter-list (pattern list)
904   (cl-loop with regexp = (funcall popup-isearch-regexp-builder-function pattern)
905            for item in list
906            do
907            (unless (stringp item)
908              (setq item (popup-item-propertize (popup-x-to-string item)
909                                                'value item)))
910            if (string-match regexp item)
911            collect
912            (let ((beg (match-beginning 0))
913                  (end (match-end 0)))
914              (alter-text-property 0 (length item) 'face
915                                   (lambda (prop)
916                                     (unless (eq prop 'popup-isearch-match)
917                                       prop))
918                                   item)
919              (put-text-property beg end
920                                 'face 'popup-isearch-match
921                                 item)
922              item)))
923
924 (defun popup-isearch-prompt (popup pattern)
925   (format "Pattern: %s" (if (= (length (popup-list popup)) 0)
926                             (propertize pattern 'face 'isearch-fail)
927                           pattern)))
928
929 (defun popup-isearch-update (popup filter pattern &optional callback)
930   (setf (popup-cursor popup) 0
931         (popup-scroll-top popup) 0
932         (popup-pattern popup) pattern)
933   (let ((list (funcall filter pattern (popup-original-list popup))))
934     (popup-set-filtered-list popup list)
935     (if callback
936         (funcall callback list)))
937   (popup-draw popup))
938
939 (cl-defun popup-isearch (popup
940                          &key
941                          (filter 'popup-isearch-filter-list)
942                          (cursor-color popup-isearch-cursor-color)
943                          (keymap popup-isearch-keymap)
944                          callback
945                          help-delay)
946   "Start isearch on POPUP. This function is synchronized, meaning
947 event loop waits for quiting of isearch.
948
949 FILTER is function with two argumenst to perform popup items filtering.
950
951 CURSOR-COLOR is a cursor color during isearch. The default value
952 is `popup-isearch-cursor-color'.
953
954 KEYMAP is a keymap which is used when processing events during
955 event loop. The default value is `popup-isearch-keymap'.
956
957 CALLBACK is a function taking one argument. `popup-isearch' calls
958 CALLBACK, if specified, after isearch finished or isearch
959 canceled. The arguments is whole filtered list of items.
960
961 HELP-DELAY is a delay of displaying helps."
962   (let ((list (popup-original-list popup))
963         (pattern (or (popup-pattern popup) ""))
964         (old-cursor-color (frame-parameter (selected-frame) 'cursor-color))
965         prompt key binding)
966     (unwind-protect
967         (cl-block nil
968           (if cursor-color
969               (set-cursor-color cursor-color))
970           (while t
971             (setq prompt (popup-isearch-prompt popup pattern))
972             (setq key (popup-menu-read-key-sequence keymap prompt help-delay))
973             (if (null key)
974                 (unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt)
975                   (clear-this-command-keys)
976                   (push (read-event prompt) unread-command-events))
977               (setq binding (lookup-key keymap key))
978               (cond
979                ((and (stringp key)
980                      (popup-isearch-char-p (aref key 0)))
981                 (setq pattern (concat pattern key)))
982                ((eq binding 'popup-isearch-done)
983                 (cl-return nil))
984                ((eq binding 'popup-isearch-cancel)
985                 (popup-isearch-update popup filter "" callback)
986                 (cl-return t))
987                ((eq binding 'popup-isearch-close)
988                 (popup-isearch-update popup filter "" callback)
989                 (setq unread-command-events
990                       (append (listify-key-sequence key) unread-command-events))
991                 (cl-return nil))
992                ((eq binding 'popup-isearch-delete)
993                 (if (> (length pattern) 0)
994                     (setq pattern (substring pattern 0 (1- (length pattern))))))
995                ((eq binding 'popup-isearch-yank)
996                 (popup-isearch-update popup filter (car kill-ring) callback)
997                 (cl-return nil))
998                (t
999                 (setq unread-command-events
1000                       (append (listify-key-sequence key) unread-command-events))
1001                 (cl-return nil)))
1002               (popup-isearch-update popup filter pattern callback))))
1003       (if old-cursor-color
1004           (set-cursor-color old-cursor-color)))))
1005
1006
1007
1008 ;;; Popup Tip
1009
1010 (defface popup-tip-face
1011   '((t (:background "khaki1" :foreground "black")))
1012   "Face for popup tip."
1013   :group 'popup)
1014
1015 (defvar popup-tip-max-width 80)
1016
1017 (cl-defun popup-tip (string
1018                      &key
1019                      point
1020                      (around t)
1021                      width
1022                      (height 15)
1023                      min-height
1024                      max-width
1025                      truncate
1026                      margin
1027                      margin-left
1028                      margin-right
1029                      scroll-bar
1030                      parent
1031                      parent-offset
1032                      nowait
1033                      nostrip
1034                      prompt
1035                      &aux tip lines)
1036   "Show a tooltip of STRING at POINT. This function is
1037 synchronized unless NOWAIT specified. Almost all arguments are
1038 the same as in `popup-create', except for TRUNCATE, NOWAIT, and
1039 PROMPT.
1040
1041 If TRUNCATE is non-nil, the tooltip can be truncated.
1042
1043 If NOWAIT is non-nil, this function immediately returns the
1044 tooltip instance without entering event loop.
1045
1046 If `NOSTRIP` is non-nil, `STRING` properties are not stripped.
1047
1048 PROMPT is a prompt string when reading events during event loop."
1049   (if (bufferp string)
1050       (setq string (with-current-buffer string (buffer-string))))
1051
1052   (unless nostrip
1053     ;; TODO strip text (mainly face) properties
1054     (setq string (substring-no-properties string)))
1055
1056   (and (eq margin t) (setq margin 1))
1057   (or margin-left (setq margin-left margin))
1058   (or margin-right (setq margin-right margin))
1059
1060   (let ((it (popup-fill-string string width popup-tip-max-width)))
1061     (setq width (car it)
1062           lines (cdr it)))
1063
1064   (setq tip (popup-create point width height
1065                           :min-height min-height
1066                           :max-width max-width
1067                           :around around
1068                           :margin-left margin-left
1069                           :margin-right margin-right
1070                           :scroll-bar scroll-bar
1071                           :face 'popup-tip-face
1072                           :parent parent
1073                           :parent-offset parent-offset))
1074
1075   (unwind-protect
1076       (when (> (popup-width tip) 0)                   ; not to be corrupted
1077         (when (and (not (eq width (popup-width tip))) ; truncated
1078                    (not truncate))
1079           ;; Refill once again to lines be fitted to popup width
1080           (setq width (popup-width tip))
1081           (setq lines (cdr (popup-fill-string string width width))))
1082
1083         (popup-set-list tip lines)
1084         (popup-draw tip)
1085         (if nowait
1086             tip
1087           (clear-this-command-keys)
1088           (push (read-event prompt) unread-command-events)
1089           t))
1090     (unless nowait
1091       (popup-delete tip))))
1092
1093
1094
1095 ;;; Popup Menu
1096
1097 (defface popup-menu-face
1098   '((t (:inherit popup-face)))
1099   "Face for popup menu."
1100   :group 'popup)
1101
1102 (defface popup-menu-mouse-face
1103   '((t (:background "blue" :foreground "white")))
1104   "Face for popup menu."
1105   :group 'popup)
1106
1107 (defface popup-menu-selection-face
1108   '((t (:inherit default :background "steelblue" :foreground "white")))
1109   "Face for popup menu selection."
1110   :group 'popup)
1111
1112 (defface popup-menu-summary-face
1113   '((t (:inherit popup-summary-face)))
1114   "Face for popup summary."
1115   :group 'popup)
1116
1117 (defvar popup-menu-show-tip-function 'popup-tip
1118   "Function used for showing tooltip by `popup-menu-show-quick-help'.")
1119
1120 (defun popup-menu-show-help (menu &optional persist item)
1121   (popup-item-show-help (or item (popup-selected-item menu)) persist))
1122
1123 (defun popup-menu-documentation (menu &optional item)
1124   (popup-item-documentation (or item (popup-selected-item menu))))
1125
1126 (defun popup-menu-show-quick-help (menu &optional item &rest args)
1127   (let* ((point (plist-get args :point))
1128          (height (or (plist-get args :height) (popup-height menu)))
1129          (min-height (min height (popup-current-height menu)))
1130          (around nil)
1131          (parent-offset (popup-offset menu))
1132          (doc (popup-menu-documentation menu item)))
1133     (when (stringp doc)
1134       (if (popup-hidden-p menu)
1135           (setq around t
1136                 menu nil
1137                 parent-offset nil)
1138         (setq point nil))
1139       (let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning
1140         (apply popup-menu-show-tip-function
1141                doc
1142                :point point
1143                :height height
1144                :min-height min-height
1145                :around around
1146                :parent menu
1147                :parent-offset parent-offset
1148                args)))))
1149
1150 (defun popup-menu-item-of-mouse-event (event)
1151   (when (and (consp event)
1152              (memq (cl-first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5)))
1153     (let* ((position (cl-second event))
1154            (object (elt position 4)))
1155       (when (consp object)
1156         (get-text-property (cdr object) 'popup-item (car object))))))
1157
1158 (defun popup-menu-read-key-sequence (keymap &optional prompt timeout)
1159   (catch 'timeout
1160     (let ((timer (and timeout
1161                       (run-with-timer timeout nil
1162                                       (lambda ()
1163                                         (if (zerop (length (this-command-keys)))
1164                                             (throw 'timeout nil))))))
1165           (old-global-map (current-global-map))
1166           (temp-global-map (make-sparse-keymap))
1167           (overriding-terminal-local-map (make-sparse-keymap)))
1168       (substitute-key-definition 'keyboard-quit 'keyboard-quit
1169                                  temp-global-map old-global-map)
1170       (define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar]))
1171       (define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar]))
1172       (set-keymap-parent overriding-terminal-local-map keymap)
1173       (if (current-local-map)
1174           (define-key overriding-terminal-local-map [menu-bar]
1175             (lookup-key (current-local-map) [menu-bar])))
1176       (unwind-protect
1177           (progn
1178             (use-global-map temp-global-map)
1179             (clear-this-command-keys)
1180             (with-temp-message prompt
1181               (read-key-sequence nil)))
1182         (use-global-map old-global-map)
1183         (if timer (cancel-timer timer))))))
1184
1185 (defun popup-menu-fallback (event default))
1186
1187 (cl-defun popup-menu-event-loop (menu
1188                                  keymap
1189                                  fallback
1190                                  &key
1191                                  prompt
1192                                  help-delay
1193                                  isearch
1194                                  isearch-filter
1195                                  isearch-cursor-color
1196                                  isearch-keymap
1197                                  isearch-callback
1198                                  &aux key binding)
1199   (cl-block nil
1200     (while (popup-live-p menu)
1201       (and isearch
1202            (popup-isearch menu
1203                           :filter isearch-filter
1204                           :cursor-color isearch-cursor-color
1205                           :keymap isearch-keymap
1206                           :callback isearch-callback
1207                           :help-delay help-delay)
1208            (keyboard-quit))
1209       (setq key (popup-menu-read-key-sequence keymap prompt help-delay))
1210       (setq binding (and key (lookup-key keymap key)))
1211       (cond
1212        ((or (null key) (zerop (length key)))
1213         (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt)
1214           (clear-this-command-keys)
1215           (push (read-event prompt) unread-command-events)))
1216        ((eq (lookup-key (current-global-map) key) 'keyboard-quit)
1217         (keyboard-quit)
1218         (cl-return))
1219        ((eq binding 'popup-close)
1220         (if (popup-parent menu)
1221             (cl-return)))
1222        ((memq binding '(popup-select popup-open))
1223         (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0))
1224                          (popup-selected-item menu)))
1225                (index (cl-position item (popup-list menu)))
1226                (sublist (popup-item-sublist item)))
1227           (unless index (cl-return))
1228           (if sublist
1229               (popup-aif (let (popup-use-optimized-column-computation)
1230                            (popup-cascade-menu sublist
1231                                                :around nil
1232                                                :margin-left (popup-margin-left menu)
1233                                                :margin-right (popup-margin-right menu)
1234                                                :scroll-bar (popup-scroll-bar menu)
1235                                                :parent menu
1236                                                :parent-offset index
1237                                                :help-delay help-delay
1238                                                :isearch isearch
1239                                                :isearch-filter isearch-filter
1240                                                :isearch-cursor-color isearch-cursor-color
1241                                                :isearch-keymap isearch-keymap
1242                                                :isearch-callback isearch-callback))
1243                   (and it (cl-return it)))
1244             (if (eq binding 'popup-select)
1245                 (cl-return (popup-item-value-or-self item))))))
1246        ((eq binding 'popup-next)
1247         (popup-next menu))
1248        ((eq binding 'popup-previous)
1249         (popup-previous menu))
1250        ((eq binding 'popup-page-next)
1251         (popup-page-next menu))
1252        ((eq binding 'popup-page-previous)
1253         (popup-page-previous menu))
1254        ((eq binding 'popup-help)
1255         (popup-menu-show-help menu))
1256        ((eq binding 'popup-isearch)
1257         (popup-isearch menu
1258                        :filter isearch-filter
1259                        :cursor-color isearch-cursor-color
1260                        :keymap isearch-keymap
1261                        :callback isearch-callback
1262                        :help-delay help-delay))
1263        ((commandp binding)
1264         (call-interactively binding))
1265        (t
1266         (funcall fallback key (key-binding key)))))))
1267
1268 (defun popup-preferred-width (list)
1269   "Return the preferred width to show LIST beautifully."
1270   (cl-loop with tab-width = 4
1271            for item in list
1272            for summary = (popup-item-summary item)
1273            maximize (string-width (popup-x-to-string item)) into width
1274            if (stringp summary)
1275            maximize (+ (string-width summary) 2) into summary-width
1276            finally return
1277            (let ((total (+ (or width 0) (or summary-width 0))))
1278              (* (ceiling (/ total 10.0)) 10))))
1279
1280 (defvar popup-menu-keymap
1281   (let ((map (make-sparse-keymap)))
1282     (define-key map "\r"        'popup-select)
1283     (define-key map "\C-f"      'popup-open)
1284     (define-key map [right]     'popup-open)
1285     (define-key map "\C-b"      'popup-close)
1286     (define-key map [left]      'popup-close)
1287
1288     (define-key map "\C-n"      'popup-next)
1289     (define-key map [down]      'popup-next)
1290     (define-key map "\C-p"      'popup-previous)
1291     (define-key map [up]        'popup-previous)
1292
1293     (define-key map [next]      'popup-page-next)
1294     (define-key map [prior]     'popup-page-previous)
1295
1296     (define-key map [f1]        'popup-help)
1297     (define-key map (kbd "\C-?") 'popup-help)
1298
1299     (define-key map "\C-s"      'popup-isearch)
1300
1301     (define-key map [mouse-1]   'popup-select)
1302     (define-key map [mouse-4]   'popup-previous)
1303     (define-key map [mouse-5]   'popup-next)
1304     map))
1305
1306 (cl-defun popup-menu* (list
1307                        &key
1308                        point
1309                        (around t)
1310                        (width (popup-preferred-width list))
1311                        (height 15)
1312                        max-width
1313                        margin
1314                        margin-left
1315                        margin-right
1316                        scroll-bar
1317                        symbol
1318                        parent
1319                        parent-offset
1320                        cursor
1321                        (keymap popup-menu-keymap)
1322                        (fallback 'popup-menu-fallback)
1323                        help-delay
1324                        nowait
1325                        prompt
1326                        isearch
1327                        (isearch-filter 'popup-isearch-filter-list)
1328                        (isearch-cursor-color popup-isearch-cursor-color)
1329                        (isearch-keymap popup-isearch-keymap)
1330                        isearch-callback
1331                        initial-index
1332                        &aux menu event)
1333   "Show a popup menu of LIST at POINT. This function returns a
1334 value of the selected item. Almost all arguments are the same as in
1335 `popup-create', except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT,
1336 ISEARCH, ISEARCH-FILTER, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and
1337 ISEARCH-CALLBACK.
1338
1339 If KEYMAP is a keymap which is used when processing events during
1340 event loop.
1341
1342 If FALLBACK is a function taking two arguments; a key and a
1343 command. FALLBACK is called when no special operation is found on
1344 the key. The default value is `popup-menu-fallback', which does
1345 nothing.
1346
1347 HELP-DELAY is a delay of displaying helps.
1348
1349 If NOWAIT is non-nil, this function immediately returns the menu
1350 instance without entering event loop.
1351
1352 PROMPT is a prompt string when reading events during event loop.
1353
1354 If ISEARCH is non-nil, do isearch as soon as displaying the popup
1355 menu.
1356
1357 ISEARCH-FILTER is a filtering function taking two arguments:
1358 search pattern and list of items. Returns a list of matching items.
1359
1360 ISEARCH-CURSOR-COLOR is a cursor color during isearch. The
1361 default value is `popup-isearch-cursor-color'.
1362
1363 ISEARCH-KEYMAP is a keymap which is used when processing events
1364 during event loop. The default value is `popup-isearch-keymap'.
1365
1366 ISEARCH-CALLBACK is a function taking one argument.  `popup-menu'
1367 calls ISEARCH-CALLBACK, if specified, after isearch finished or
1368 isearch canceled. The arguments is whole filtered list of items.
1369
1370 If `INITIAL-INDEX' is non-nil, this is an initial index value for
1371 `popup-select'. Only positive integer is valid."
1372   (and (eq margin t) (setq margin 1))
1373   (or margin-left (setq margin-left margin))
1374   (or margin-right (setq margin-right margin))
1375   (if (and scroll-bar
1376            (integerp margin-right)
1377            (> margin-right 0))
1378       ;; Make scroll-bar space as margin-right
1379       (cl-decf margin-right))
1380   (setq menu (popup-create point width height
1381                            :max-width max-width
1382                            :around around
1383                            :face 'popup-menu-face
1384                            :mouse-face 'popup-menu-mouse-face
1385                            :selection-face 'popup-menu-selection-face
1386                            :summary-face 'popup-menu-summary-face
1387                            :margin-left margin-left
1388                            :margin-right margin-right
1389                            :scroll-bar scroll-bar
1390                            :symbol symbol
1391                            :parent parent
1392                            :parent-offset parent-offset))
1393   (unwind-protect
1394       (progn
1395         (popup-set-list menu list)
1396         (if cursor
1397             (popup-jump menu cursor)
1398           (popup-draw menu))
1399         (when initial-index
1400           (dotimes (_i (min (- (length list) 1) initial-index))
1401             (popup-next menu)))
1402         (if nowait
1403             menu
1404           (popup-menu-event-loop menu keymap fallback
1405                                  :prompt prompt
1406                                  :help-delay help-delay
1407                                  :isearch isearch
1408                                  :isearch-filter isearch-filter
1409                                  :isearch-cursor-color isearch-cursor-color
1410                                  :isearch-keymap isearch-keymap
1411                                  :isearch-callback isearch-callback)))
1412     (unless nowait
1413       (popup-delete menu))))
1414
1415 (defun popup-cascade-menu (list &rest args)
1416   "Same as `popup-menu' except that an element of LIST can be
1417 also a sub-menu if the element is a cons cell formed (ITEM
1418 . SUBLIST) where ITEM is an usual item and SUBLIST is a list of
1419 the sub menu."
1420   (apply 'popup-menu*
1421          (mapcar (lambda (item)
1422                    (if (consp item)
1423                        (popup-make-item (car item)
1424                                         :sublist (cdr item)
1425                                         :symbol ">")
1426                      item))
1427                  list)
1428          :symbol t
1429          args))
1430
1431 (provide 'popup)
1432 ;;; popup.el ends here