[nongnu] elpa/popup cb51206 008/184: Add mouse support.

[ELPA Syncer]

branch: elpa/popup
commit cb51206c40e187c08df9b2ee85a337313c09614e
Author: Tomohiro Matsuyama <tomo@cx4a.org>
Commit: Tomohiro Matsuyama <tomo@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)