1 ;;; appmenu.el --- A framework for [apps] popup menus.
3 ;; Copyright (C) 2008 by Lennart Borgman
5 ;; Author: Lennart Borgman <lennart DOT borgman AT gmail DOT com>
6 ;; Created: Thu Jan 05 14:00:26 2006
7 (defconst appmenu:version "0.63") ;; Version:
8 ;; Last-Updated: 2010-01-04 Mon
12 ;; Features that might be required by this library:
16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20 ;; appmenu.el is a framework for creating cooperative context
21 ;; sensitive popup menus with commands from different major and minor
22 ;; modes. For more information see `appmenu-mode'.
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;; - Remove support for minor and major menus.
30 ;; - Add support for text and overlay keymaps.
31 ;; - Add customization options.
34 ;; - Fix problem with keymap at point.
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 ;; This program is free software; you can redistribute it and/or modify
39 ;; it under the terms of the GNU General Public License as published by
40 ;; the Free Software Foundation; either version 2, or (at your option)
43 ;; This program is distributed in the hope that it will be useful,
44 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
45 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
46 ;; GNU General Public License for more details.
48 ;; You should have received a copy of the GNU General Public License
49 ;; along with this program; see the file COPYING. If not, write to the
50 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
51 ;; Boston, MA 02111-1307, USA.
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 (eval-when-compile (require 'cl))
58 (eval-when-compile (require 'flyspell))
59 (eval-when-compile (require 'help-mode))
60 (eval-when-compile (require 'ourcomments-util nil t))
61 (eval-when-compile (require 'mumamo nil t))
62 ;;(eval-when-compile (require 'mlinks nil t))
66 "Customization group for `appmenu-mode'."
69 (defcustom appmenu-show-help nil
70 "Non-nil means show AppMenu help on AppMenu popup."
74 (defcustom appmenu-show-point-menu t
75 "If non-nil show entries fetched from keymaps at point."
79 (defvar appmenu-alist nil
80 "List of additional menu keymaps.
81 To change this list use `appmenu-add' and `appmenu-remove'.
83 The entries in this list are lists:
85 \(ID PRIORITY TEST TITLE DEFINITION)
87 ID is a unique identity.
89 PRIORITY is a number or a variable whose value is a number
90 telling where to put this entry when showing the menu.
92 TEST should be a form to evaluate. The entry is used if \(eval
93 TEST) returns non-nil.
95 DEFINITION should be either a keymap or a function that returns a
98 The function must take no argument and return a keymap. If the
99 function returns nil then the entry is not shown in the popup
100 menu. Using this you can make context sensitive popup menus.
102 For an example of use see mlinks.el.")
104 (defun appmenu-sort-by-priority ()
105 "Sort `appmenu-alist' entries by priority."
109 (let ((priA (nth 1 recA))
111 (when (symbolp priA) (setq priA (symbol-value priA)))
112 (when (symbolp priB) (setq priB (symbol-value priB)))
116 (defun appmenu-add (id priority test title definition)
117 "Add entry to `appmenu-alist'.
118 Add an entry to this list with ID, PRIORITY, TEST, TITLE and
119 DEFINITION as explained there."
120 (assert (symbolp id))
121 (unless priority (setq priority 100))
122 (assert (numberp priority))
123 (assert (stringp title))
124 (let ((rec (list id priority test title definition)))
126 (add-to-list 'appmenu-alist rec)))
128 (defun appmenu-remove (id)
129 "Remove entry with id ID from `appmenu-alist'."
130 (setq appmenu-alist (assq-delete-all id appmenu-alist)))
132 (defun appmenu-help ()
133 "Show help for minor mode function `appmenu-mode'."
135 (describe-function 'appmenu-mode))
137 (defun appmenu-keymap-len (map)
138 "Return length of keymap MAP."
140 (map-keymap (lambda (e f) (setq ml (1+ ml))) map)
143 (defvar appmenu-mouse-only
144 '((flyspell-correct-word appmenu-flyspell-correct-word-before-point)))
146 (defun appmenu-flyspell-correct-word-before-point ()
147 "Pop up a menu of possible corrections for misspelled word before point.
148 Special version for AppMenu."
150 (flyspell-correct-word-before-point))
152 (defcustom appmenu-at-any-point '(ispell-word)
153 "Commands that may work at any point in a buffer.
154 Some important but not too often used commands that may be useful
155 for most points in a buffer."
158 (defvar appmenu-map-fun) ;; dyn var, silence compiler
160 (defun appmenu-make-menu-for-point (this-point)
161 "Construct a menu based on point THIS-POINT.
162 This includes some known commands for point and keymap at
164 (let ((point-map (get-char-property this-point 'keymap))
165 (funs appmenu-at-any-point)
166 (map (make-sparse-keymap "At point"))
170 ;; Known for any point
172 (let ((appmenu-map-fun
175 (map-keymap appmenu-map-fun fun)
176 (when (and (symbolp fun)
178 (let ((mouse-only (assq fun appmenu-mouse-only)))
180 (setq fun (cadr mouse-only)))
181 (add-to-list 'funs fun)))))))
182 (map-keymap appmenu-map-fun point-map)))
184 (let ((desc (when fun (documentation fun))))
186 (setq desc (car (split-string desc "[\n]")))
187 ;;(lwarn t :warning "pk: %s, %s" fun desc)
189 (car (split-string (symbol-name fun) "[-]")))
190 (when (and last-prefix
191 (not (string= last-prefix this-prefix)))
193 (vector (intern (format "appmenu-point-div-%s" num)))
194 (list 'menu-item "--")))
195 (setq last-prefix this-prefix)
198 (vector (intern (format "appmenu-point-%s" num)))
199 (list 'menu-item desc fun)))))
200 (when (> num 0) map)))
202 (defvar appmenu-level) ;; dyn var
203 (defvar appmenu-funs) ;; dyn var
204 (defvar appmenu-events) ;; dyn var
205 (defvar appmenu-this-point) ;; dyn var
207 (defun appmenu-keymap-map-fun (ev def)
210 (add-to-list 'appmenu-funs (list appmenu-level ev))
211 (setq appmenu-events (cons ev appmenu-events))
212 (setq appmenu-level (1+ appmenu-level))
214 (map-keymap 'appmenu-keymap-map-fun def)
216 (setq appmenu-events (cdr appmenu-events))
217 (setq appmenu-level (1- appmenu-level)))
218 (when (and (symbolp def)
220 (let* ((mouse-only (assq def appmenu-mouse-only))
221 (fun (if mouse-only (cadr mouse-only) def))
223 (if (not (eq fun 'push-button))
227 (with-current-buffer (marker-buffer appmenu-this-point)
228 (or (get-char-property appmenu-this-point 'help-echo)
229 (let ((action-fun (get-char-property appmenu-this-point 'action)))
231 (documentation action-fun)
232 "No action, ignored"))
233 "No documentation available")))))))
234 (add-to-list 'appmenu-funs (list appmenu-level (cons ev appmenu-events) def doc))))))
236 ;;(appmenu-as-help (point))
237 (defun appmenu-as-help (this-point)
238 "Show keybindings specific done current point in buffer.
239 This shows the binding in the help buffer.
241 Tip: This may be helpful if you are using `css-color-mode'."
242 (interactive (list (copy-marker (point))))
243 ;; Split this for debugging
245 (with-current-buffer (or (and (markerp this-point)
246 (marker-buffer this-point))
248 (unless (markerp this-point) (setq this-point (copy-marker this-point)))
249 (get-char-property this-point 'keymap))))
250 ;;(describe-variable 'menu-here)
251 (appmenu-as-help-1 menu-here this-point)))
253 (defun appmenu-as-help-1 (menu-here this-point)
254 (let ((appmenu-level 0)
257 (appmenu-this-point this-point))
259 (map-keymap 'appmenu-keymap-map-fun menu-here))
260 ;;(describe-variable 'appmenu-funs)
261 ;; Fix-me: collect info first in case we are in help-buffer!
262 (with-output-to-temp-buffer (help-buffer)
263 (help-setup-xref (list #'appmenu-as-help this-point) (interactive-p))
264 (with-current-buffer (help-buffer)
265 (let ((fmt " %s%15s %-30s\n"))
267 ;;"AppMenu: Keys found at point in buffer\n\n"
268 (format "Appmenu: Key bindings specific to point %s in buffer %S\n\n"
270 (when (markerp this-point)
271 (buffer-name (marker-buffer this-point))))
272 'face 'font-lock-comment-face))
274 (insert "\n\nThere are no point specific key bindings there now.")
275 (insert (propertize (format fmt "" "Key" "Function") 'face 'font-lock-function-name-face))
276 (insert (propertize (format fmt "" "---" "--------") 'face 'font-lock-function-name-face))
277 (dolist (rec appmenu-funs)
278 (let* ((lev (nth 0 rec))
282 (d1 (when doc (car (split-string doc "[\n]")))))
285 "" ;;(concat "*" (make-string (* 4 lev) ?\ ))
286 (key-description (reverse ev))
288 (if nil (format "(%s)" fun) ""))
289 ;;(insert (format "something else=%S\n" rec))
293 (defun appmenu-map ()
294 "Return menu keymap to use for popup menu."
295 (let* ((map (make-sparse-keymap
298 (map-len (appmenu-keymap-len map))
299 (map-init-len map-len)
302 (point-menu (when appmenu-show-point-menu
303 (appmenu-make-menu-for-point (point)))))
305 (when appmenu-show-help
306 (define-key map [appmenu-customize]
307 (list 'menu-item "Customize AppMenu"
308 (lambda () (interactive) (customize-group 'appmenu))
309 :help "Customize AppMenu"
310 :visible 'appmenu-show-help))
311 (define-key map [appmenu-help]
312 (list 'menu-item "Help for AppMenu" 'appmenu-help
313 :help "Help for how to use AppMenu"
314 :visible 'appmenu-show-help))
315 (define-key map [appmenu-separator-1]
316 (list 'menu-item "--")))
317 (setq map-len (appmenu-keymap-len map))
318 (appmenu-sort-by-priority)
319 (dolist (rec appmenu-alist)
320 (let* ((test (nth 2 rec))
323 (usedef (if (symbolp mapdef)
330 (vector (intern (format "appmenu-%s" id)))
331 (list 'menu-item title usedef)))
334 (setq map-len (appmenu-keymap-len map))
335 (when (> map-len map-init-len)
336 (define-key map [appmenu-at-point-div]
337 (list 'menu-item "--")))
338 (define-key map [appmenu-at-point]
339 (list 'menu-item "Bound To Point"
341 (setq map-len (appmenu-keymap-len map))
342 (when (> map-len map-init-len)
345 ;; (defun appmenu-get-submenu (menu-command)
346 ;; (let (subtitle submenumap)
347 ;; (if (eq 'menu-item (car menu-command))
348 ;; (progn (setq subtitle (cadr menu-command))
349 ;; (setq submenumap (caddr menu-command)))
350 ;; (setq subtitle (car menu-command))
351 ;; (setq submenumap (cdr menu-command)))
352 ;; (unless (keymapp submenumap) (error "Submenu not a keymap=%s" submenumap))
353 ;; (cons subtitle submenumap)))
355 (defun appmenu-popup ()
356 "Pops up the AppMenu menu."
358 (let* ((mod (event-modifiers last-input-event))
359 (is-mouse (or (memq 'click mod)
363 (goto-char (posn-point (event-start last-input-event)))
365 (let ((menu (appmenu-map)))
367 (popup-menu-at-point menu)
368 (message "Appmenu is empty")))))
370 (defvar appmenu-mode-map
371 (let ((map (make-sparse-keymap)))
372 (define-key map [apps] 'appmenu-popup)
373 (define-key map [mouse-3] 'appmenu-popup)
374 (define-key map [(control apps)] 'appmenu-as-help)
378 ;;(setq appmenu-auto-help 4)
379 (defcustom appmenu-auto-help 2
380 "Automatically show help on keymap at current point.
381 This shows up after the number of seconds in this variable.
382 If it it nil this feature is off.
384 This feature is only on in `appmenu-mode'."
385 :type '(choice (number :tag "Number of seconds to wait")
386 (const :tag "Turned off" nil))
387 :set (lambda (sym val)
388 (set-default sym val)
390 (add-hook 'post-command-hook 'appmenu-auto-help-post-command nil t)
391 (remove-hook 'post-command-hook 'appmenu-auto-help-post-command t)))
394 (defcustom appmenu-auto-match-keymaps
396 "Keymaps listed here can be avoided."
397 :type '(set (const unknown)
402 (defvar appmenu-auto-help-timer nil)
404 (defun appmenu-dump-keymap (km)
405 (let ((fun (lambda (ev def)
406 (message "ev=%S def=%S" ev def)
408 (map-keymap fun def)))))
409 (map-keymap fun km)))
411 (defun appmenu-on-keymap (where)
412 (setq where (or where (point)))
413 (let* ((rec (get-char-property-and-overlay where 'keymap))
417 (or (memq 'unknown appmenu-auto-match-keymaps)
418 (and (memq 'css-color appmenu-auto-match-keymaps)
419 (get-text-property where 'css-color-type))
420 (and (memq 'mlinks appmenu-auto-match-keymaps)
421 (boundp 'mlinks-point-hilighter-overlay)
422 (eq ovl mlinks-point-hilighter-overlay))
425 (defsubst appmenu-auto-help-add-wcfg (at-point wcfg)
426 (mumamo-with-buffer-prepared-for-jit-lock
427 (add-text-properties at-point (1+ at-point)
428 (list 'point-left 'appmenu-auto-help-maybe-remove
429 'appmenu-auto-help-wcfg wcfg))))
431 (defsubst appmenu-auto-help-remove-wcfg (at-point)
432 (mumamo-with-buffer-prepared-for-jit-lock
433 (remove-list-of-text-properties at-point (1+ at-point)
434 '(appmenu-auto-help-wcfg point-left))))
436 (defun appmenu-auto-help-maybe-remove (at-point new-point)
437 "Run in 'point-left property.
438 Restores window configuration."
439 (let ((old-wcfg (get-text-property at-point 'appmenu-auto-help-wcfg)))
440 (appmenu-auto-help-remove-wcfg at-point)
441 (if (appmenu-on-keymap new-point)
442 (appmenu-auto-help-add-wcfg new-point old-wcfg)
444 (set-window-configuration old-wcfg)
445 (help-xref-go-back (help-buffer))))))
447 (defun appmenu-as-help-in-timer (win buf)
449 (when (and (eq (selected-window) win)
450 (eq (current-buffer) buf)
452 (appmenu-on-keymap (point)))
453 (let* ((old-help-win (get-buffer-window (help-buffer)))
454 (wcfg (unless old-help-win
455 (current-window-configuration))))
457 (display-buffer (help-buffer)))
458 (appmenu-auto-help-add-wcfg (point) wcfg)
459 (appmenu-as-help (copy-marker (point)))))
460 (error (message "appmenu-as-help-in-timer: %s" (error-message-string err)))))
462 (defun appmenu-auto-help-cancel-timer ()
463 (when (timerp appmenu-auto-help-timer)
464 (cancel-timer appmenu-auto-help-timer))
465 (setq appmenu-auto-help-timer nil))
467 (defun appmenu-auto-help-post-command ()
468 (when (fboundp 'appmenu-as-help)
470 (appmenu-auto-help-post-command-1)
471 (error (message "css-color-post-command: %s" (error-message-string err))))))
474 (defun appmenu-auto-help-post-command-1 ()
475 (appmenu-auto-help-cancel-timer)
476 (and appmenu-auto-help
477 (appmenu-on-keymap (point))
478 (not (get-text-property (point) 'appmenu-auto-help-wcfg))
479 (setq appmenu-auto-help-timer
480 (run-with-idle-timer appmenu-auto-help nil 'appmenu-as-help-in-timer
486 (define-minor-mode appmenu-mode
487 "Use a context sensitive popup menu.
488 AppMenu (appmenu.el) is a framework for creating cooperative
489 context sensitive popup menus with commands from different major
490 and minor modes. Using this different modes may cooperate about
491 the use of popup menus.
493 There is also the command `appmenu-as-help' that shows the key
494 bindings at current point in the help buffer.
496 The popup menu and the help buffer version are on these keys:
500 The variable `appmenu-alist' is where the popup menu entries
503 If there is a `keymap' property at point then relevant bindings
504 from this is also shown in the popup menu.
506 You can write functions that use whatever information you want in
507 Emacs to construct these entries. Since this information is only
508 collected when the popup menu is shown you do not have to care as
509 much about computation time as for entries in the menu bar."
511 :keymap appmenu-mode-map
514 (add-hook 'post-command-hook 'appmenu-auto-help-post-command)
515 (remove-hook 'post-command-hook 'appmenu-auto-help-post-command)))
517 (when (and appmenu-mode
518 (not (boundp 'define-globa-minor-mode-bug)))
522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
523 ;;; appmenu.el ends here