branch: elpa/popup
commit cb51206c40e187c08df9b2ee85a337313c09614e
Author: Tomohiro Matsuyama <t...@cx4a.org>
Commit: Tomohiro Matsuyama <t...@cx4a.org>
Add mouse support.
---
popup.el | 170 ++++++++++++++++++++++++++++++++++++++++-----------------------
1 file changed, 108 insertions(+), 62 deletions(-)
diff --git a/popup.el b/popup.el
index c3a00e5..d8dc861 100644
--- a/popup.el
+++ b/popup.el
@@ -28,7 +28,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'cl)
@@ -38,12 +38,17 @@
"Use the optimized column computation routine.
If there is a problem, please set it nil.")
-(defmacro popup-aif (test-form then-form &rest else-forms)
- "Anaphoric if. Temporary variable `it' is the result of
-TEST-FORM."
+(defmacro popup-aif (test then &rest else)
+ "Anaphoric if."
(declare (indent 2))
- `(let ((it ,test-form))
- (if it ,then-form ,@else-forms)))
+ `(let ((it ,test))
+ (if it ,then ,@else)))
+
+(defmacro popup-awhen (test &rest body)
+ "Anaphoric when."
+ (declare (indent 1))
+ `(let ((it ,test))
+ (when it ,@body)))
(defun popup-x-to-string (x)
"Convert any object to string effeciently.
@@ -230,9 +235,9 @@ buffer."
"Background character for scroll-bar.")
(defstruct popup
- point row column width height min-height direction overlays
+ point row column width height min-height direction overlays keymap
parent depth
- face selection-face
+ face mouse-face selection-face
margin-left margin-right margin-left-cancel scroll-bar symbol
cursor offset scroll-top current-height list newlines
pattern original-list)
@@ -256,7 +261,8 @@ ITEM is not string."
(defun* popup-make-item (name
&key
value
- popup-face
+ face
+ mouse-face
selection-face
sublist
document
@@ -266,7 +272,8 @@ ITEM is not string."
`popup-item-propertize'."
(popup-item-propertize name
'value value
- 'popup-face popup-face
+ 'popup-face face
+ 'popup-mouse-face mouse-face
'selection-face selection-face
'document document
'symbol symbol
@@ -275,7 +282,8 @@ ITEM is not string."
(defsubst popup-item-value (item) (popup-item-property item
'value))
(defsubst popup-item-value-or-self (item) (or (popup-item-value item)
item))
-(defsubst popup-item-popup-face (item) (popup-item-property item
'popup-face))
+(defsubst popup-item-face (item) (popup-item-property item
'popup-face))
+(defsubst popup-item-mouse-face (item) (popup-item-property item
'popup-mouse-face))
(defsubst popup-item-selection-face (item) (popup-item-property item
'selection-face))
(defsubst popup-item-document (item) (popup-item-property item
'document))
(defsubst popup-item-summary (item) (popup-item-property item
'summary))
@@ -359,7 +367,7 @@ usual."
(and (eq (overlay-get overlay 'display) nil)
(eq (overlay-get overlay 'after-string) nil))))
-(defun* popup-set-line-item (popup line &key item face margin-left
margin-right scroll-bar-char symbol summary)
+(defun* popup-set-line-item (popup line &key item face mouse-face margin-left
margin-right scroll-bar-char symbol summary keymap)
(let* ((overlay (popup-line-overlay popup line))
(content (popup-create-line-string popup (popup-x-to-string item)
:margin-left margin-left
@@ -370,14 +378,18 @@ usual."
(prefix (overlay-get overlay 'prefix))
(postfix (overlay-get overlay 'postfix))
end)
+ (put-text-property 0 (length content) 'popup-item item content)
+ (put-text-property 0 (length content) 'keymap keymap content)
;; Overlap face properties
- (if (get-text-property start 'face content)
- (setq start (next-single-property-change start 'face content)))
+ (when (get-text-property start 'face content)
+ (setq start (next-single-property-change start 'face content)))
(while (and start (setq end (next-single-property-change start 'face
content)))
(put-text-property start end 'face face content)
(setq start (next-single-property-change end 'face content)))
- (if start
- (put-text-property start (length content) 'face face content))
+ (when start
+ (put-text-property start (length content) 'face face content))
+ (when mouse-face
+ (put-text-property 0 (length content) 'mouse-face mouse-face content))
(unless (overlay-get overlay 'dangle)
(overlay-put overlay 'display (concat prefix (substring content 0 1)))
(setq prefix nil
@@ -439,13 +451,15 @@ number at the point."
min-height
around
(face 'popup-face)
+ mouse-face
(selection-face face)
scroll-bar
margin-left
margin-right
symbol
parent
- parent-offset)
+ parent-offset
+ keymap)
"Create a popup instance at POINT with WIDTH and HEIGHT.
MIN-HEIGHT is a minimal height of the popup. The default value is
@@ -473,7 +487,9 @@ 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."
+PARENT-OFFSET is a row offset from the parent popup.
+
+KEYMAP is a keymap that will be put on the popup contents."
(or margin-left (setq margin-left 0))
(or margin-right (setq margin-right 0))
(unless point
@@ -587,6 +603,7 @@ PARENT-OFFSET is a row offset from the parent popup."
:parent parent
:depth depth
:face face
+ :mouse-face mouse-face
:selection-face selection-face
:margin-left margin-left
:margin-right margin-right
@@ -599,7 +616,8 @@ PARENT-OFFSET is a row offset from the parent popup."
:current-height 0
:list nil
:newlines newlines
- :overlays overlays)))
+ :overlays overlays
+ :keymap keymap)))
(push it popup-instances)
it))))
@@ -625,6 +643,7 @@ PARENT-OFFSET is a row offset from the parent popup."
(loop with height = (popup-height popup)
with min-height = (popup-min-height popup)
with popup-face = (popup-face popup)
+ with mouse-face = (popup-mouse-face popup)
with selection-face = (popup-selection-face popup)
with list = (popup-list popup)
with length = (length list)
@@ -637,6 +656,7 @@ PARENT-OFFSET is a row offset from the parent popup."
with cursor = (popup-cursor popup)
with scroll-top = (popup-scroll-top popup)
with offset = (popup-offset popup)
+ with keymap = (popup-keymap popup)
for o from offset
for i from scroll-top
while (< o height)
@@ -644,7 +664,7 @@ PARENT-OFFSET is a row offset from the parent popup."
for page-index = (* thum-size (/ o thum-size))
for face = (if (= i cursor)
(or (popup-item-selection-face item) selection-face)
- (or (popup-item-popup-face item) popup-face))
+ (or (popup-item-face item) popup-face))
for empty-char = (propertize " " 'face face)
for scroll-bar-char = (if scroll-bar
(cond
@@ -668,11 +688,13 @@ PARENT-OFFSET is a row offset from the parent popup."
(popup-set-line-item popup o
:item item
:face face
+ :mouse-face mouse-face
:margin-left margin-left
:margin-right margin-right
:scroll-bar-char scroll-bar-char
:symbol sym
- :summary summary)
+ :summary summary
+ :keymap keymap)
finally
;; Remember current height
@@ -989,6 +1011,11 @@ PROMPT is a prompt string when reading events during
event loop."
"Face for popup menu."
:group 'popup)
+(defface popup-menu-mouse-face
+ '((t (:background "blue" :foreground "white")))
+ "Face for popup menu."
+ :group 'popup)
+
(defface popup-menu-selection-face
'((t (:background "steelblue" :foreground "white")))
"Face for popup menu selection."
@@ -1030,6 +1057,14 @@ PROMPT is a prompt string when reading events during
event loop."
:parent-offset parent-offset
args)))))
+(defun popup-menu-item-of-mouse-event (event)
+ (when (and (consp event)
+ (memq (first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5)))
+ (let* ((position (second event))
+ (object (elt position 4)))
+ (when (consp object)
+ (get-text-property (cdr object) 'popup-item (car object))))))
+
(defun popup-menu-read-key-sequence (keymap &optional prompt timeout)
(catch 'timeout
(let ((timer (and timeout
@@ -1080,46 +1115,51 @@ PROMPT is a prompt string when reading events during
event loop."
:help-delay help-delay)
(keyboard-quit))
(setq key (popup-menu-read-key-sequence keymap prompt help-delay))
- (if (null key)
- (unless (funcall popup-menu-show-quick-help-function menu nil
:prompt prompt)
- (clear-this-command-keys)
- (push (read-event prompt) unread-command-events))
- (if (eq (lookup-key (current-global-map) key) 'keyboard-quit)
- (keyboard-quit))
- (setq binding (lookup-key keymap key))
- (cond
- ((eq binding 'popup-close)
- (if (popup-parent menu)
- (return)))
- ((memq binding '(popup-select popup-open))
- (let* ((item (popup-selected-item menu))
- (sublist (popup-item-sublist item)))
- (if sublist
- (popup-aif (popup-cascade-menu sublist
- :around nil
- :parent menu
- :margin-left (popup-margin-left
menu)
- :margin-right
(popup-margin-right menu)
- :scroll-bar (popup-scroll-bar
menu))
- (and it (return it)))
- (if (eq binding 'popup-select)
- (return (popup-item-value-or-self item))))))
- ((eq binding 'popup-next)
- (popup-next menu))
- ((eq binding 'popup-previous)
- (popup-previous menu))
- ((eq binding 'popup-help)
- (popup-menu-show-help menu))
- ((eq binding 'popup-isearch)
- (popup-isearch menu
- :cursor-color isearch-cursor-color
- :keymap isearch-keymap
- :callback isearch-callback
- :help-delay help-delay))
- ((commandp binding)
- (call-interactively binding))
- (t
- (funcall fallback key (key-binding key))))))))
+ (setq binding (lookup-key keymap key))
+ (cond
+ ((or (null key) (zerop (length key)))
+ (unless (funcall popup-menu-show-quick-help-function menu nil :prompt
prompt)
+ (clear-this-command-keys)
+ (push (read-event prompt) unread-command-events)))
+ ((eq (lookup-key (current-global-map) key) 'keyboard-quit)
+ (keyboard-quit)
+ (return))
+ ((eq binding 'popup-close)
+ (if (popup-parent menu)
+ (return)))
+ ((memq binding '(popup-select popup-open))
+ (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0))
+ (popup-selected-item menu)))
+ (index (position item (popup-list menu)))
+ (sublist (popup-item-sublist item)))
+ (unless index (return))
+ (if sublist
+ (popup-aif (popup-cascade-menu sublist
+ :around nil
+ :margin-left (popup-margin-left
menu)
+ :margin-right (popup-margin-right
menu)
+ :scroll-bar (popup-scroll-bar
menu)
+ :parent menu
+ :parent-offset index)
+ (and it (return it)))
+ (if (eq binding 'popup-select)
+ (return (popup-item-value-or-self item))))))
+ ((eq binding 'popup-next)
+ (popup-next menu))
+ ((eq binding 'popup-previous)
+ (popup-previous menu))
+ ((eq binding 'popup-help)
+ (popup-menu-show-help menu))
+ ((eq binding 'popup-isearch)
+ (popup-isearch menu
+ :cursor-color isearch-cursor-color
+ :keymap isearch-keymap
+ :callback isearch-callback
+ :help-delay help-delay))
+ ((commandp binding)
+ (call-interactively binding))
+ (t
+ (funcall fallback key (key-binding key)))))))
(defun* popup-menu* (list
&key
@@ -1188,12 +1228,14 @@ isearch canceled. The arguments is whole filtered list
of items."
(setq menu (popup-create point width height
:around around
:face 'popup-menu-face
+ :mouse-face 'popup-menu-mouse-face
:selection-face 'popup-menu-selection-face
:margin-left margin-left
:margin-right margin-right
:scroll-bar scroll-bar
:symbol symbol
- :parent parent))
+ :parent parent
+ :parent-offset parent-offset))
(unwind-protect
(progn
(popup-set-list menu list)
@@ -1243,6 +1285,10 @@ the sub menu."
(define-key map (kbd "\C-?") 'popup-help)
(define-key map "\C-s" 'popup-isearch)
+
+ (define-key map [mouse-1] 'popup-select)
+ (define-key map [mouse-4] 'popup-previous)
+ (define-key map [mouse-5] 'popup-next)
map))
(provide 'popup)
