branch: elpa/popup
commit 8937b927f9f02b3f33af7cd9fe8f383be7e28998
Author: Tomohiro Matsuyama <t...@cx4a.org>
Commit: Tomohiro Matsuyama <t...@cx4a.org>
Refactoring and auto-test.
---
popup-test.el | 124 ++++++++++++++++
popup.el | 469 ++++++++++++++++++++++++++++++++++++++++------------------
2 files changed, 451 insertions(+), 142 deletions(-)
diff --git a/popup-test.el b/popup-test.el
new file mode 100644
index 0000000..3839717
--- /dev/null
+++ b/popup-test.el
@@ -0,0 +1,124 @@
+(require 'popup)
+
+(defmacro test (explain &rest body)
+ (declare (indent 1))
+ `(let ((buf "*buf*")
+ (window-config (current-window-configuration)))
+ (unwind-protect
+ (progn
+ (delete-other-windows)
+ (switch-to-buffer buf)
+ (erase-buffer)
+ (insert " ")
+ (let ((success (progn ,@body)))
+ (unless success
+ (error "failed: %s" ,explain))))
+ (when popup
+ (popup-delete popup)
+ (setq popup nil))
+ (kill-buffer buf)
+ (set-window-configuration window-config))))
+
+(defmacro ui-test (prompt &rest body)
+ (declare (indent 1))
+ `(test ,prompt ,@body (yes-or-no-p ,prompt)))
+
+(defun input (key)
+ (push key unread-command-events))
+
+(defvar popup nil)
+
+(test "popup-create"
+ (setq popup (popup-create (point) 10 10)))
+
+(test "popup-delete"
+ (setq popup (popup-create (point) 10 10))
+ (popup-delete popup)
+ (not (popup-live-p popup)))
+
+(ui-test "popup?"
+ (setq popup (popup-create (point) 10 10))
+ (popup-set-list popup '("hello" "world"))
+ (popup-draw popup))
+
+(ui-test "hidden?"
+ (setq popup (popup-create (point) 10 10))
+ (popup-set-list popup '("hello" "world"))
+ (popup-draw popup)
+ (popup-hide popup))
+
+(ui-test "isearch?"
+ (setq popup (popup-create (point) 10 10))
+ (popup-set-list popup '("hello" "world"))
+ (popup-draw popup)
+ (input ?e)
+ (popup-isearch popup))
+
+(ui-test "tip?"
+ (popup-tip
+ "Start isearch on POPUP. This function is synchronized, meaning
+event loop waits for quiting of isearch.
+
+CURSOR-COLOR is a cursor color during isearch. The default value
+is `popup-isearch-cursor-color'.
+
+KEYMAP is a keymap which is used when processing events during
+event loop. The default value is `popup-isearch-keymap'.
+
+CALLBACK is a function taking one argument. `popup-isearch' calls
+CALLBACK, if specified, after isearch finished or isearch
+canceled. The arguments is whole filtered list of items.
+
+HELP-DELAY is a delay of displaying helps."
+ :nowait t))
+
+(ui-test "fold?"
+ (let ((s (make-string (- (window-width) 3) ? )))
+ (insert s)
+ (setq popup (popup-tip "long long long long line" :nowait t))))
+
+(ui-test "fold?"
+ (let ((s (make-string (- (window-height) 3) ?\n)))
+ (insert s)
+ (setq popup (popup-tip "bla\nbla\nbla\nbla\nbla" :nowait t))))
+
+(ui-test "margin?"
+ (setq popup (popup-tip "Margin?" :nowait t :margin t)))
+
+(ui-test "two lines?"
+ (setq popup (popup-tip "Foo\nBar\nBaz" :nowait t :height 2)))
+
+(ui-test "scroll bar?"
+ (setq popup (popup-tip "Foo\nBar\nBaz\nFez\nOz" :nowait t :height 3
:scroll-bar t :margin t)))
+
+(ui-test "min-height?"
+ (setq popup (popup-tip "Hello" :nowait t :min-height 10)))
+
+(ui-test "menu?"
+ (setq popup (popup-menu* '("Foo" "Bar" "Baz") :nowait t)))
+
+(ui-test "cascade menu?"
+ (setq popup (popup-cascade-menu '(("Foo" "Foo1" "Foo2") "Bar" "Baz") :nowait
t :margin t)))
+
+(ui-test "next?"
+ (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t))
+ (popup-next popup))
+
+(ui-test "previous?"
+ (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t))
+ (popup-previous popup))
+
+(ui-test "select?"
+ (setq popup (popup-cascade-menu '("Foo" "Bar" "Baz") :nowait t :margin t))
+ (popup-select popup 1))
+
+(ui-test "scroll-down?"
+ (setq popup (popup-cascade-menu (loop repeat 100 collect "Foo") :nowait t
:height 10 :margin t :scroll-bar t))
+ (popup-scroll-down popup 10))
+
+(ui-test "scroll-up?"
+ (setq popup (popup-cascade-menu (loop repeat 100 collect "Foo") :nowait t
:height 10 :margin t :scroll-bar t))
+ (popup-scroll-down popup 999)
+ (popup-scroll-up popup 10))
+
+(message "Congratulations!")
diff --git a/popup.el b/popup.el
index e26bf02..41605d5 100644
--- a/popup.el
+++ b/popup.el
@@ -1,4 +1,4 @@
-;;; popup.el --- Visual popup interface
+;;; popup.el --- Visual Popup User Interface
;; Copyright (C) 2009, 2010, 2011 Tomohiro Matsuyama
@@ -30,22 +30,22 @@
-;; Utilities
+;;; Utilities
(defvar popup-use-optimized-column-computation t
- "Use optimized column computation routine.
-If there is a problem, please set it to nil.")
+ "Use the optimized column computation routine.
+If there is a problem, please set it nil.")
-;; Borrowed from anything.el
(defmacro popup-aif (test-form then-form &rest else-forms)
- "Anaphoric if. Temporary variable `it' is the result of test-form."
+ "Anaphoric if. Temporary variable `it' is the result of
+TEST-FORM."
(declare (indent 2))
`(let ((it ,test-form))
(if it ,then-form ,@else-forms)))
(defun popup-x-to-string (x)
"Convert any object to string effeciently.
-This is faster than prin1-to-string in many cases."
+This is faster than `prin1-to-string' in many cases."
(typecase x
(string x)
(symbol (symbol-name x))
@@ -54,8 +54,9 @@ This is faster than prin1-to-string in many cases."
(t (format "%s" x))))
(defun popup-substring-by-width (string width)
- "Return cons of substring and remaining string by `WIDTH'."
- ;; Expand tabs with 4 spaces
+ "Return a cons cell of substring and remaining string by
+splitting with WIDTH."
+ ;; Expand tabs into 4 spaces
(setq string (replace-regexp-in-string "\t" " " string))
(loop with len = (length string)
with w = 0
@@ -68,20 +69,25 @@ This is faster than prin1-to-string in many cases."
(list string))))
(defun popup-fill-string (string &optional width max-width justify squeeze)
- "Split STRING into fixed width strings and return a cons cell like
-\(WIDTH . ROWS). Here, the car WIDTH indicates the actual maxim width of ROWS.
+ "Split STRING into fixed width strings and return a cons cell
+like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual
+maxim width of ROWS.
-The argument WIDTH specifies the width of filling each paragraph. WIDTH nil
-means don't perform any justification and word wrap. Note that this function
-doesn't add any padding characters at the end of each row.
+The argument WIDTH specifies the width of filling each
+paragraph. WIDTH nil means don't perform any justification and
+word wrap. Note that this function doesn't add any padding
+characters at the end of each row.
-MAX-WIDTH, if WIDTH is nil, specifies the maximum number of columns.
+MAX-WIDTH, if WIDTH is nil, specifies the maximum number of
+columns.
-The optional fourth argument JUSTIFY specifies which kind of justification
-to do: `full', `left', `right', `center', or `none' (equivalent to nil).
-A value of t means handle each paragraph as specified by its text properties.
+The optional fourth argument JUSTIFY specifies which kind of
+justification to do: `full', `left', `right', `center', or
+`none' (equivalent to nil). A value of t means handle each
+paragraph as specified by its text properties.
-SQUEEZE nil means leave whitespaces other than line breaks untouched."
+SQUEEZE nil means leave whitespaces other than line breaks
+untouched."
(if (eq width 0)
(error "Can't fill string with 0 width"))
(if width
@@ -126,23 +132,25 @@ SQUEEZE nil means leave whitespaces other than line
breaks untouched."
(set-buffer-modified-p modified)))))
(defun popup-preferred-width (list)
- "Return preferred width of popup to show `LIST' beautifully."
+ "Return the preferred width to show LIST beautifully."
(loop with tab-width = 4
for item in list
for summary = (popup-item-summary item)
maximize (string-width (popup-x-to-string item)) into width
if (stringp summary)
maximize (+ (string-width summary) 2) into summary-width
- finally return (* (ceiling (/ (+ (or width 0) (or summary-width 0))
10.0)) 10)))
+ finally return
+ (let ((total (+ (or width 0) (or summary-width 0))))
+ (* (ceiling (/ total 10.0)) 10))))
-;; window-full-width-p is not defined in Emacs 22.1
(defun popup-window-full-width-p (&optional window)
+ "A portable version of `window-full-width-p'."
(if (fboundp 'window-full-width-p)
(window-full-width-p window)
(= (window-width window) (frame-width (window-frame (or window
(selected-window)))))))
-;; truncated-partial-width-window-p is not defined in Emacs 22
(defun popup-truncated-partial-width-window-p (&optional window)
+ "A portable version of `truncated-partial-width-window-p'."
(unless window
(setq window (selected-window)))
(unless (popup-window-full-width-p window)
@@ -153,6 +161,7 @@ SQUEEZE nil means leave whitespaces other than line breaks
untouched."
t-p-w-w))))
(defun popup-current-physical-column ()
+ "Return the current physical column."
(or (when (and popup-use-optimized-column-computation
(eq (window-hscroll) 0))
(let ((current-column (current-column)))
@@ -162,22 +171,33 @@ SQUEEZE nil means leave whitespaces other than line
breaks untouched."
current-column)))
(car (posn-col-row (posn-at-point)))))
+(defun popup-vertical-motion (column direction)
+ "A portable version of `vertical-motion'."
+ (if (>= emacs-major-version 23)
+ (vertical-motion (cons column direction))
+ (vertical-motion direction)
+ (move-to-column (+ (current-column) column))))
+
(defun popup-last-line-of-buffer-p ()
+ "Return non-nil if the cursor is at the last line of the
+buffer."
(save-excursion (end-of-line) (/= (forward-line) 0)))
(defun popup-lookup-key-by-event (function event)
(or (funcall function (vector event))
(if (symbolp event)
(popup-aif (get event 'event-symbol-element-mask)
- (funcall function (vector (logior (or (get (car it)
'ascii-character) 0)
- (cadr it))))))))
+ (funcall function
+ (vector (logior (or (get (car it) 'ascii-character)
+ 0)
+ (cadr it))))))))
-;; Popup common
+;;; Core
(defgroup popup nil
- "Visual popup interface"
+ "Visual Popup User Interface"
:group 'lisp
:prefix "popup-")
@@ -216,18 +236,18 @@ SQUEEZE nil means leave whitespaces other than line
breaks untouched."
pattern original-list)
(defun popup-item-propertize (item &rest properties)
- "Same to `propertize` but this avoids overriding existed value with `nil`
property."
- (let (props)
- (while properties
- (when (cadr properties)
- (push (car properties) props)
- (push (cadr properties) props))
- (setq properties (cddr properties)))
- (apply 'propertize
- (popup-x-to-string item)
- (nreverse props))))
+ "Same as `propertize' except that this avoids overriding
+existed value with `nil' property."
+ (loop for (k v) on properties by 'cddr
+ if v append (list k v) into props
+ finally return
+ (apply 'propertize
+ (popup-x-to-string item)
+ props)))
(defun popup-item-property (item property)
+ "Same as `get-text-property' except that this returns nil if
+ITEM is not string."
(if (stringp item)
(get-text-property 0 property item)))
@@ -240,8 +260,8 @@ SQUEEZE nil means leave whitespaces other than line breaks
untouched."
document
symbol
summary)
- "Utility function to make popup item.
-See also `popup-item-propertize'."
+ "Utility function to make popup item. See also
+`popup-item-propertize'."
(popup-item-propertize name
'value value
'popup-face popup-face
@@ -276,23 +296,30 @@ See also `popup-item-propertize'."
(display-buffer (current-buffer)))
t)))
+(defun popup-item-show-help-with-event-loop (item)
+ (save-window-excursion
+ (when (popup-item-show-help-1 item)
+ (loop do (clear-this-command-keys)
+ for key = (read-key-sequence-vector nil)
+ do
+ (case (key-binding key)
+ ('scroll-other-window
+ (scroll-other-window))
+ ('scroll-other-window-down
+ (scroll-other-window-down nil))
+ (t
+ (setq unread-command-events (append key unread-command-events))
+ (return)))))))
+
(defun popup-item-show-help (item &optional persist)
+ "Display the documentation of ITEM with `display-buffer'. If
+PERSIST is nil, the documentation buffer will be closed
+automatically, meaning interal event loop ensures the buffer to
+be closed. Otherwise, the buffer will be just displayed as
+usual."
(when item
(if (not persist)
- (save-window-excursion
- (when (popup-item-show-help-1 item)
- (block nil
- (while t
- (clear-this-command-keys)
- (let ((key (read-key-sequence-vector nil)))
- (case (key-binding key)
- ('scroll-other-window
- (scroll-other-window))
- ('scroll-other-window-down
- (scroll-other-window-down nil))
- (t
- (setq unread-command-events (append key
unread-command-events))
- (return))))))))
+ (popup-item-show-help-with-event-loop item)
(popup-item-show-help-1 item))))
(defun popup-set-list (popup list)
@@ -301,10 +328,12 @@ See also `popup-item-propertize'."
(setf (popup-original-list popup) list))
(defun popup-set-filtered-list (popup list)
- (setf (popup-list popup) list
- (popup-offset popup) (if (> (popup-direction popup) 0)
- 0
- (max (- (popup-height popup) (length list))
0))))
+ (let ((offset
+ (if (> (popup-direction popup) 0)
+ 0
+ (max (- (popup-height popup) (length list)) 0))))
+ (setf (popup-list popup) list
+ (popup-offset popup) offset)))
(defun popup-selected-item (popup)
(nth (popup-cursor popup) (popup-list popup)))
@@ -328,9 +357,13 @@ See also `popup-item-propertize'."
(and (eq (overlay-get overlay 'display) nil)
(eq (overlay-get overlay 'after-string) nil))))
-(defun popup-set-line-item (popup line item face margin-left margin-right
scroll-bar-char symbol summary)
+(defun* popup-set-line-item (popup line &key item face margin-left
margin-right scroll-bar-char symbol summary)
(let* ((overlay (popup-line-overlay popup line))
- (content (popup-create-line-string popup (popup-x-to-string item)
margin-left margin-right symbol summary))
+ (content (popup-create-line-string popup (popup-x-to-string item)
+ :margin-left margin-left
+ :margin-right margin-right
+ :symbol symbol
+ :summary summary))
(start 0)
(prefix (overlay-get overlay 'prefix))
(postfix (overlay-get overlay 'postfix))
@@ -354,29 +387,48 @@ See also `popup-item-propertize'."
scroll-bar-char
postfix))))
-(defun popup-create-line-string (popup string margin-left margin-right symbol
summary)
+(defun* popup-create-line-string (popup string &key margin-left margin-right
symbol summary)
(let* ((popup-width (popup-width popup))
(summary-width (string-width summary))
- (string (car (popup-substring-by-width string
- (- popup-width
- (if (> summary-width 0)
- (+ summary-width 2)
- 0)))))
- (string-width (string-width string)))
+ (content-width (- popup-width
+ (if (> summary-width 0)
+ (+ summary-width 2)
+ 0)))
+ (string (car (popup-substring-by-width string content-width)))
+ (string-width (string-width string))
+ (spacing (max (- popup-width string-width summary-width) 0)))
(concat margin-left
string
- (make-string (max (- popup-width string-width summary-width) 0) ? )
+ (make-string spacing ? )
summary
symbol
margin-right)))
(defun popup-live-p (popup)
+ "Return non-nil if POPUP is alive."
(and popup (popup-overlays popup) t))
(defun popup-child-point (popup &optional offset)
- (overlay-end (popup-line-overlay popup
- (or offset
- (popup-selected-line popup)))))
+ (overlay-end
+ (popup-line-overlay
+ popup
+ (or offset
+ (popup-selected-line popup)))))
+
+(defun popup-calculate-direction (height row)
+ "Return a proper direction when displaying a popup on this
+window. HEIGHT is the a height of the popup, and ROW is a line
+number at the point."
+ (let* ((remaining-rows (- (max 1 (- (window-height)
+ (if mode-line-format 1 0)
+ (if header-line-format 1 0)))
+ (count-lines (window-start) (point))))
+ (enough-space-above (> row height))
+ (enough-space-below (<= height remaining-rows)))
+ (if (and enough-space-above
+ (not enough-space-below))
+ -1
+ 1)))
(defun* popup-create (point
width
@@ -392,6 +444,34 @@ See also `popup-item-propertize'."
symbol
parent
parent-offset)
+ "Create a popup instance at POINT with WIDTH and HEIGHT.
+
+MIN-HEIGHT is a minimal height of the popup. The default value is
+0.
+
+If AROUND is non-nil, the popup will be displayed around the
+point but not at the point.
+
+FACE is a background face of the popup. The default value is POPUP-FACE.
+
+SELECTION-FACE is a foreground (selection) face of the popup The
+default value is POPUP-FACE.
+
+If SCROLL-BAR is non-nil, the popup will have a scroll bar at the
+right.
+
+If MARGIN-LEFT is non-nil, the popup will have a margin at the
+left.
+
+If MARGIN-RIGHT is non-nil, the popup will have a margin at the
+right.
+
+SYMBOL is a single character which indicates a kind of the item.
+
+PARENT is a parent popup instance. If PARENT is omitted, the
+popup will be a root instance.
+
+PARENT-OFFSET is a row offset from the parent popup."
(or margin-left (setq margin-left 0))
(or margin-right (setq margin-right 0))
(unless point
@@ -423,36 +503,34 @@ See also `popup-item-propertize'."
(and parent (popup-direction parent))
;; Calculate direction
- (if (and (> row height)
- (> height (- (max 1 (- (window-height)
- (if mode-line-format 1
0)
- (if header-line-format
1 0)))
- (count-lines window-start
(point)))))
- -1
- 1)))
+ (popup-calculate-direction height row)))
(depth (if parent (1+ (popup-depth parent)) 0))
(newlines (max 0 (+ (- height (count-lines point (point-max))) (if
around 1 0))))
current-column)
+ ;; Case: no newlines at the end of the buffer
(when (> newlines 0)
(popup-save-buffer-state
(goto-char (point-max))
(insert (make-string newlines ?\n))))
+ ;; Case: the popup overflows
(if overflow
(if foldable
(progn
(decf column (- popup-width margin-left margin-right))
(unless around (move-to-column column)))
(when (not truncate-lines)
- ;; Cut out overflow
+ ;; Truncate.
(let ((d (1+ (- popup-width (- window-width column)))))
(decf popup-width d)
(decf width d)))
(decf column margin-left))
(decf column margin-left))
+
+ ;; Case: no space at the left
(when (and (null parent)
(< column 0))
- ;; Cancel margin left
+ ;; Cancel margin left
(setq column 0)
(decf popup-width margin-left)
(setq margin-left-cancel t))
@@ -460,10 +538,7 @@ See also `popup-item-propertize'."
(dotimes (i height)
(let (overlay begin w (dangle t) (prefix "") (postfix ""))
(when around
- (if (>= emacs-major-version 23)
- (vertical-motion (cons column direction))
- (vertical-motion direction)
- (move-to-column (+ (current-column) column))))
+ (popup-vertical-motion column direction))
(setq around t
current-column (popup-current-physical-column))
@@ -472,11 +547,12 @@ See also `popup-item-propertize'."
(setq current-column (popup-current-physical-column)))
(when (< current-column column)
;; Extend short buffer lines by popup prefix (line of spaces)
- (setq prefix (make-string (+ (if (= current-column 0)
- (- window-hscroll
(current-column))
- 0)
- (- column current-column))
- ? )))
+ (setq prefix (make-string
+ (+ (if (= current-column 0)
+ (- window-hscroll (current-column))
+ 0)
+ (- column current-column))
+ ? )))
(setq begin (point))
(setq w (+ popup-width (length prefix)))
@@ -516,6 +592,7 @@ See also `popup-item-propertize'."
:scroll-bar scroll-bar
:symbol symbol
:cursor 0
+ :offset 0
:scroll-top 0
:current-height 0
:list nil
@@ -525,11 +602,13 @@ See also `popup-item-propertize'."
it))))
(defun popup-delete (popup)
+ "Delete POPUP instance."
(when (popup-live-p popup)
(popup-hide popup)
(mapc 'delete-overlay (popup-overlays popup))
(setf (popup-overlays popup) nil)
(setq popup-instances (delq popup popup-instances))
+ ;; Restore newlines state
(let ((newlines (popup-newlines popup)))
(when (> newlines 0)
(popup-save-buffer-state
@@ -540,6 +619,7 @@ See also `popup-item-propertize'."
nil)
(defun popup-draw (popup)
+ "Draw POPUP."
(loop with height = (popup-height popup)
with min-height = (popup-min-height popup)
with popup-face = (popup-face popup)
@@ -582,7 +662,14 @@ See also `popup-item-propertize'."
do
;; Show line and set item to the line
- (popup-set-line-item popup o item face margin-left margin-right
scroll-bar-char sym summary)
+ (popup-set-line-item popup o
+ :item item
+ :face face
+ :margin-left margin-left
+ :margin-right margin-right
+ :scroll-bar-char scroll-bar-char
+ :symbol sym
+ :summary summary)
finally
;; Remember current height
@@ -595,7 +682,14 @@ See also `popup-item-propertize'."
(progn
(when min-height
(while (< o min-height)
- (popup-set-line-item popup o "" popup-face margin-left
margin-right scroll-bar-char symbol "")
+ (popup-set-line-item popup o
+ :item ""
+ :face popup-face
+ :margin-left margin-left
+ :margin-right margin-right
+ :scroll-bar-char scroll-bar-char
+ :symbol symbol
+ :summary "")
(incf o)))
(while (< o height)
(popup-hide-line popup o)
@@ -605,13 +699,22 @@ See also `popup-item-propertize'."
if (< o h)
do (popup-hide-line popup o)
if (>= o h)
- do (popup-set-line-item popup o "" popup-face margin-left
margin-right scroll-bar-char symbol ""))))))
+ do (popup-set-line-item popup o
+ :item ""
+ :face popup-face
+ :margin-left margin-left
+ :margin-right margin-right
+ :scroll-bar-char scroll-bar-char
+ :symbol symbol
+ :summary ""))))))
(defun popup-hide (popup)
+ "Hide POPUP."
(dotimes (i (popup-height popup))
(popup-hide-line popup i)))
(defun popup-hidden-p (popup)
+ "Return non-nil if POPUP is hidden."
(let ((hidden t))
(when (popup-live-p popup)
(dotimes (i (popup-height popup))
@@ -620,6 +723,7 @@ See also `popup-item-propertize'."
hidden))
(defun popup-select (popup i)
+ "Select the item at I of POPUP and draw."
(setq i (+ i (popup-offset popup)))
(when (and (<= 0 i) (< i (popup-height popup)))
(setf (popup-cursor popup) i)
@@ -627,6 +731,7 @@ See also `popup-item-propertize'."
t))
(defun popup-next (popup)
+ "Select the next item of POPUP and draw."
(let ((height (popup-height popup))
(cursor (1+ (popup-cursor popup)))
(scroll-top (popup-scroll-top popup))
@@ -644,6 +749,7 @@ See also `popup-item-propertize'."
(popup-draw popup)))
(defun popup-previous (popup)
+ "Select the previous item of POPUP and draw."
(let ((height (popup-height popup))
(cursor (1- (popup-cursor popup)))
(scroll-top (popup-scroll-top popup))
@@ -661,6 +767,7 @@ See also `popup-item-propertize'."
(popup-draw popup)))
(defun popup-scroll-down (popup &optional n)
+ "Scroll down N of POPUP and draw."
(let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1))
(- (length (popup-list popup)) (popup-height
popup)))))
(setf (popup-cursor popup) scroll-top
@@ -668,6 +775,7 @@ See also `popup-item-propertize'."
(popup-draw popup)))
(defun popup-scroll-up (popup &optional n)
+ "Scroll up N of POPUP and draw."
(let ((scroll-top (max (- (popup-scroll-top popup) (or n 1))
0)))
(setf (popup-cursor popup) scroll-top
@@ -676,7 +784,7 @@ See also `popup-item-propertize'."
-;; Popup isearch
+;;; Popup Incremental Search
(defface popup-isearch-match
'((t (:background "sky blue")))
@@ -706,17 +814,18 @@ See also `popup-item-propertize'."
(setq item (popup-item-propertize (popup-x-to-string item)
'value item)))
if (string-match regexp item)
- collect (let ((beg (match-beginning 0))
- (end (match-end 0)))
- (alter-text-property 0 (length item) 'face
- (lambda (prop)
- (unless (eq prop 'popup-isearch-match)
- prop))
- item)
- (put-text-property beg end
- 'face 'popup-isearch-match
- item)
- item)))
+ collect
+ (let ((beg (match-beginning 0))
+ (end (match-end 0)))
+ (alter-text-property 0 (length item) 'face
+ (lambda (prop)
+ (unless (eq prop 'popup-isearch-match)
+ prop))
+ item)
+ (put-text-property beg end
+ 'face 'popup-isearch-match
+ item)
+ item)))
(defun popup-isearch-prompt (popup pattern)
(format "Pattern: %s" (if (= (length (popup-list popup)) 0)
@@ -739,46 +848,59 @@ See also `popup-item-propertize'."
(keymap popup-isearch-keymap)
callback
help-delay)
+ "Start isearch on POPUP. This function is synchronized, meaning
+event loop waits for quiting of isearch.
+
+CURSOR-COLOR is a cursor color during isearch. The default value
+is `popup-isearch-cursor-color'.
+
+KEYMAP is a keymap which is used when processing events during
+event loop. The default value is `popup-isearch-keymap'.
+
+CALLBACK is a function taking one argument. `popup-isearch' calls
+CALLBACK, if specified, after isearch finished or isearch
+canceled. The arguments is whole filtered list of items.
+
+HELP-DELAY is a delay of displaying helps."
(let ((list (popup-original-list popup))
(pattern (or (popup-pattern popup) ""))
(old-cursor-color (frame-parameter (selected-frame) 'cursor-color))
- prompt key binding done)
+ prompt key binding)
(unwind-protect
- (unless (block nil
- (if cursor-color
- (set-cursor-color cursor-color))
- (while t
- (setq prompt (popup-isearch-prompt popup pattern))
- (setq key (popup-menu-read-key-sequence keymap prompt
help-delay))
- (if (null key)
- (unless (funcall popup-menu-show-quick-help-function
popup nil :prompt prompt)
- (clear-this-command-keys)
- (push (read-event prompt) unread-command-events))
- (setq binding (lookup-key keymap key))
- (cond
- ((and (stringp key)
- (popup-isearch-char-p (aref key 0)))
- (setq pattern (concat pattern key)))
- ((eq binding 'popup-isearch-done)
- (return t))
- ((eq binding 'popup-isearch-cancel)
- (return nil))
- ((eq binding 'popup-isearch-delete)
- (if (> (length pattern) 0)
- (setq pattern (substring pattern 0 (1- (length
pattern))))))
- (t
- (setq unread-command-events
- (append (listify-key-sequence key)
unread-command-events))
- (return t)))
- (popup-isearch-update popup pattern callback))))
- (popup-isearch-update popup "" callback)
- t) ; Return non-nil if isearch is cancelled
+ (block nil
+ (if cursor-color
+ (set-cursor-color cursor-color))
+ (while t
+ (setq prompt (popup-isearch-prompt popup pattern))
+ (setq key (popup-menu-read-key-sequence keymap prompt help-delay))
+ (if (null key)
+ (unless (funcall popup-menu-show-quick-help-function popup nil
:prompt prompt)
+ (clear-this-command-keys)
+ (push (read-event prompt) unread-command-events))
+ (setq binding (lookup-key keymap key))
+ (cond
+ ((and (stringp key)
+ (popup-isearch-char-p (aref key 0)))
+ (setq pattern (concat pattern key)))
+ ((eq binding 'popup-isearch-done)
+ (return nil))
+ ((eq binding 'popup-isearch-cancel)
+ (popup-isearch-update popup "" callback)
+ (return t))
+ ((eq binding 'popup-isearch-delete)
+ (if (> (length pattern) 0)
+ (setq pattern (substring pattern 0 (1- (length
pattern))))))
+ (t
+ (setq unread-command-events
+ (append (listify-key-sequence key)
unread-command-events))
+ (return nil)))
+ (popup-isearch-update popup pattern callback))))
(if old-cursor-color
(set-cursor-color old-cursor-color)))))
-;; Popup tip
+;;; Popup Tip
(defface popup-tip-face
'((t (:background "khaki1" :foreground "black")))
@@ -804,6 +926,16 @@ See also `popup-item-propertize'."
nowait
prompt
&aux tip lines)
+ "Show a tooltip of STRING at POINT. This function is
+synchronized unless NOWAIT specified. Almost arguments are same
+as `popup-create' except for TRUNCATE, NOWAIT, and PROMPT.
+
+If TRUNCATE is non-nil, the tooltip can be truncated.
+
+If NOWAIT is non-nil, this function immediately returns the
+tooltip instance without entering event loop.
+
+PROMPT is a prompt string when reading events during event loop."
(if (bufferp string)
(setq string (with-current-buffer string (buffer-string))))
;; TODO strip text (mainly face) properties
@@ -847,7 +979,7 @@ See also `popup-item-propertize'."
-;; Popup menu
+;;; Popup Menu
(defface popup-menu-face
'((t (:background "lightgray" :foreground "black")))
@@ -924,7 +1056,17 @@ See also `popup-item-propertize'."
(defun popup-menu-fallback (event default))
-(defun* popup-menu-event-loop (menu keymap fallback &optional prompt
help-delay isearch isearch-cursor-color isearch-keymap isearch-callback &aux
key binding)
+(defun* popup-menu-event-loop (menu
+ keymap
+ fallback
+ &key
+ prompt
+ help-delay
+ isearch
+ isearch-cursor-color
+ isearch-keymap
+ isearch-callback
+ &aux key binding)
(block nil
(while (popup-live-p menu)
(and isearch
@@ -976,7 +1118,6 @@ See also `popup-item-propertize'."
(t
(funcall fallback key (key-binding key))))))))
-;; popup-menu is used by mouse.el unfairly...
(defun* popup-menu* (list
&key
point
@@ -993,12 +1134,46 @@ See also `popup-item-propertize'."
(keymap popup-menu-keymap)
(fallback 'popup-menu-fallback)
help-delay
+ nowait
prompt
isearch
(isearch-cursor-color popup-isearch-cursor-color)
(isearch-keymap popup-isearch-keymap)
isearch-callback
&aux menu event)
+ "Show a popup menu of LIST at POINT. This function returns a
+value of the selected item unless. Almost arguments are same as
+`popup-create' except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT,
+ISEARCH, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and
+ISEARCH-CALLBACK.
+
+If KEYMAP is a keymap which is used when processing events during
+event loop.
+
+If FALLBACK is a function taking two arguments; a key and a
+command. FALLBACK is called when no special operation is found on
+the key. The default value is `popup-menu-fallback', which does
+nothing.
+
+HELP-DELAY is a delay of displaying helps.
+
+If NOWAIT is non-nil, this function immediately returns the menu
+instance without entering event loop.
+
+PROMPT is a prompt string when reading events during event loop.
+
+If ISEARCH is non-nil, do isearch as soon as displaying the popup
+menu.
+
+ISEARCH-CURSOR-COLOR is a cursor color during isearch. The
+default value is `popup-isearch-cursor-color'.
+
+ISEARCH-KEYMAP is a keymap which is used when processing events
+during event loop. The default value is `popup-isearch-keymap'.
+
+ISEARCH-CALLBACK is a function taking one argument. `popup-menu'
+calls ISEARCH-CALLBACK, if specified, after isearch finished or
+isearch canceled. The arguments is whole filtered list of items."
(and (eq margin t) (setq margin 1))
(or margin-left (setq margin-left margin))
(or margin-right (setq margin-right margin))
@@ -1020,13 +1195,23 @@ See also `popup-item-propertize'."
(progn
(popup-set-list menu list)
(popup-draw menu)
- (popup-menu-event-loop menu keymap fallback prompt help-delay isearch
- isearch-cursor-color isearch-keymap
isearch-callback))
- (popup-delete menu)))
+ (if nowait
+ menu
+ (popup-menu-event-loop menu keymap fallback
+ :prompt prompt
+ :help-delay help-delay
+ :isearch isearch
+ :isearch-cursor-color isearch-cursor-color
+ :isearch-keymap isearch-keymap
+ :isearch-callback isearch-callback)))
+ (unless nowait
+ (popup-delete menu))))
(defun popup-cascade-menu (list &rest args)
- "Same to `popup-menu', but an element of `LIST' can be
-list of submenu."
+ "Same as `popup-menu' except that an element of LIST can be
+also a sub-menu if the element is a cons cell formed (ITEM
+. SUBLIST) where ITEM is an usual item and SUBLIST is a list of
+the sub menu."
(apply 'popup-menu*
(mapcar (lambda (item)
(if (consp item)
