emacs/nxhtml/util/appmenu.el

   1 ;;; appmenu.el --- A framework for [apps] popup menus.
   2
   3 ;; Copyright (C) 2008 by Lennart Borgman
   4
   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
   9 ;; Keywords:
  10 ;; Compatibility:
  11 ;;
  12 ;; Features that might be required by this library:
  13 ;;
  14 ;;   None
  15 ;;
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;;
  18 ;;; Commentary:
  19 ;;
  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'.
  23 ;;
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;
  26 ;;; Change log:
  27 ;;
  28 ;; Version 0.61:
  29 ;; - Remove support for minor and major menus.
  30 ;; - Add support for text and overlay keymaps.
  31 ;; - Add customization options.
  32 ;;
  33 ;; Version 0.62:
  34 ;; - Fix problem with keymap at point.
  35 ;;
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;;
  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)
  41 ;; any later version.
  42 ;;
  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.
  47 ;;
  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.
  52 ;;
  53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54 ;;
  55 ;;; Code:
  56
  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))
  63
  64 ;;;###autoload
  65 (defgroup appmenu nil
  66   "Customization group for `appmenu-mode'."
  67   :group 'convenience)
  68
  69 (defcustom appmenu-show-help nil
  70   "Non-nil means show AppMenu help on AppMenu popup."
  71   :type 'boolean
  72   :group 'appmenu)
  73
  74 (defcustom appmenu-show-point-menu t
  75   "If non-nil show entries fetched from keymaps at point."
  76   :type 'boolean
  77   :group 'appmenu)
  78
  79 (defvar appmenu-alist nil
  80   "List of additional menu keymaps.
  81 To change this list use `appmenu-add' and `appmenu-remove'.
  82
  83 The entries in this list are lists:
  84
  85    \(ID PRIORITY TEST TITLE DEFINITION)
  86
  87 ID is a unique identity.
  88
  89 PRIORITY is a number or a variable whose value is a number
  90 telling where to put this entry when showing the menu.
  91
  92 TEST should be a form to evaluate.  The entry is used if \(eval
  93 TEST) returns non-nil.
  94
  95 DEFINITION should be either a keymap or a function that returns a
  96 keymap.
  97
  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.
 101
 102 For an example of use see mlinks.el.")
 103
 104 (defun appmenu-sort-by-priority ()
 105   "Sort `appmenu-alist' entries by priority."
 106   (setq appmenu-alist
 107         (sort appmenu-alist
 108               (lambda (recA recB)
 109                 (let ((priA (nth 1 recA))
 110                       (priB (nth 1 recB)))
 111                   (when (symbolp priA) (setq priA (symbol-value priA)))
 112                   (when (symbolp priB) (setq priB (symbol-value priB)))
 113                   (< priA priB))))))
 114
 115 ;;;###autoload
 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)))
 125     (appmenu-remove id)
 126     (add-to-list 'appmenu-alist rec)))
 127
 128 (defun appmenu-remove (id)
 129   "Remove entry with id ID from `appmenu-alist'."
 130   (setq appmenu-alist (assq-delete-all id appmenu-alist)))
 131
 132 (defun appmenu-help ()
 133   "Show help for minor mode function `appmenu-mode'."
 134   (interactive)
 135   (describe-function 'appmenu-mode))
 136
 137 (defun appmenu-keymap-len (map)
 138   "Return length of keymap MAP."
 139   (let ((ml 0))
 140     (map-keymap (lambda (e f) (setq ml (1+ ml))) map)
 141     ml))
 142
 143 (defvar appmenu-mouse-only
 144   '((flyspell-correct-word appmenu-flyspell-correct-word-before-point)))
 145
 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."
 149   (interactive)
 150   (flyspell-correct-word-before-point))
 151
 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."
 156   :group 'appmenu)
 157
 158 (defvar appmenu-map-fun) ;; dyn var, silence compiler
 159
 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
 163 point."
 164   (let ((point-map (get-char-property this-point 'keymap))
 165         (funs appmenu-at-any-point)
 166         (map (make-sparse-keymap "At point"))
 167         (num 0)
 168         last-prefix
 169         this-prefix)
 170     ;; Known for any point
 171     (when point-map
 172       (let ((appmenu-map-fun
 173              (lambda (key fun)
 174                (if (keymapp fun)
 175                    (map-keymap appmenu-map-fun fun)
 176                  (when (and (symbolp fun)
 177                             (fboundp fun))
 178                    (let ((mouse-only (assq fun appmenu-mouse-only)))
 179                      (when mouse-only
 180                        (setq fun (cadr mouse-only)))
 181                      (add-to-list 'funs fun)))))))
 182         (map-keymap appmenu-map-fun point-map)))
 183     (dolist (fun funs)
 184       (let ((desc (when fun (documentation fun))))
 185         (when desc
 186           (setq desc (car (split-string desc "[\n]")))
 187           ;;(lwarn t :warning "pk: %s, %s" fun desc)
 188           (setq this-prefix
 189                 (car (split-string (symbol-name fun) "[-]")))
 190           (when (and last-prefix
 191                      (not (string= last-prefix this-prefix)))
 192             (define-key map
 193               (vector (intern (format "appmenu-point-div-%s" num)))
 194               (list 'menu-item "--")))
 195           (setq last-prefix this-prefix)
 196           (setq num (1+ num))
 197           (define-key map
 198             (vector (intern (format "appmenu-point-%s" num)))
 199             (list 'menu-item desc fun)))))
 200     (when (> num 0) map)))
 201
 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
 206
 207 (defun appmenu-keymap-map-fun (ev def)
 208   (if (keymapp def)
 209         (progn
 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))
 213
 214           (map-keymap 'appmenu-keymap-map-fun def)
 215
 216           (setq appmenu-events (cdr appmenu-events))
 217           (setq appmenu-level (1- appmenu-level)))
 218       (when (and (symbolp def)
 219                  (fboundp def))
 220         (let* ((mouse-only (assq def appmenu-mouse-only))
 221                (fun (if mouse-only (cadr mouse-only) def))
 222                (doc (when fun
 223                       (if (not (eq fun 'push-button))
 224                           (documentation fun)
 225                         (concat
 226                          "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)))
 230                                  (if action-fun
 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))))))
 235
 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.
 240
 241 Tip: This may be helpful if you are using `css-color-mode'."
 242   (interactive (list (copy-marker (point))))
 243   ;; Split this for debugging
 244   (let ((menu-here
 245          (with-current-buffer (or (and (markerp this-point)
 246                                        (marker-buffer this-point))
 247                                   (current-buffer))
 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)))
 252
 253 (defun appmenu-as-help-1 (menu-here this-point)
 254   (let ((appmenu-level 0)
 255         (appmenu-funs nil)
 256         (appmenu-events nil)
 257         (appmenu-this-point this-point))
 258     (when menu-here
 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"))
 266           (insert (propertize
 267                    ;;"AppMenu: Keys found at point in buffer\n\n"
 268                    (format "Appmenu: Key bindings specific to point %s in buffer %S\n\n"
 269                            (+ 0 this-point)
 270                            (when (markerp this-point)
 271                              (buffer-name (marker-buffer this-point))))
 272                    'face 'font-lock-comment-face))
 273           (if (not menu-here)
 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))
 279                      (ev  (nth 1 rec))
 280                      (fun (nth 2 rec))
 281                      (doc (nth 3 rec))
 282                      (d1  (when doc (car (split-string doc "[\n]")))))
 283                 (if fun
 284                     (insert (format fmt
 285                                     "" ;;(concat "*" (make-string (* 4 lev) ?\ ))
 286                                     (key-description (reverse ev))
 287                                     d1)
 288                             (if nil (format "(%s)" fun) ""))
 289                   ;;(insert (format "something else=%S\n" rec))
 290                   )))))))))
 291
 292
 293 (defun appmenu-map ()
 294   "Return menu keymap to use for popup menu."
 295   (let* ((map (make-sparse-keymap
 296                "AppMenu"
 297                ))
 298          (map-len (appmenu-keymap-len map))
 299          (map-init-len map-len)
 300          (num-minor 0)
 301          (id 0)
 302          (point-menu (when appmenu-show-point-menu
 303                        (appmenu-make-menu-for-point (point)))))
 304     ;; AppMenu itself
 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))
 321              (title  (nth 3 rec))
 322              (mapdef (nth 4 rec))
 323              (usedef (if (symbolp mapdef)
 324                          (funcall mapdef)
 325                        mapdef)))
 326         (when (and usedef
 327                    (eval test))
 328           (setq id (1+ id))
 329           (define-key map
 330             (vector (intern (format "appmenu-%s" id)))
 331             (list 'menu-item title usedef)))
 332         ))
 333     (when point-menu
 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"
 340               point-menu)))
 341     (setq map-len (appmenu-keymap-len map))
 342     (when (> map-len map-init-len)
 343       map)))
 344
 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)))
 354
 355 (defun appmenu-popup ()
 356   "Pops up the AppMenu menu."
 357   (interactive)
 358   (let* ((mod (event-modifiers last-input-event))
 359          (is-mouse (or (memq 'click mod)
 360                        (memq 'down  mod)
 361                        (memq 'drag  mod))))
 362     (when is-mouse
 363       (goto-char (posn-point (event-start last-input-event)))
 364       (sit-for 0.01))
 365     (let ((menu (appmenu-map)))
 366       (if menu
 367           (popup-menu-at-point menu)
 368         (message "Appmenu is empty")))))
 369
 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)
 375     map))
 376
 377
 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.
 383
 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)
 389          (if 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)))
 392   :group 'appmenu)
 393
 394 (defcustom appmenu-auto-match-keymaps
 395   '(css-color)
 396   "Keymaps listed here can be avoided."
 397   :type '(set (const unknown)
 398               (const mlink)
 399               (const css-color))
 400   :group 'appmenu)
 401
 402 (defvar appmenu-auto-help-timer nil)
 403
 404 (defun appmenu-dump-keymap (km)
 405   (let ((fun (lambda (ev def)
 406                (message "ev=%S def=%S" ev def)
 407                (when (keymapp def)
 408                  (map-keymap fun def)))))
 409     (map-keymap fun km)))
 410
 411 (defun appmenu-on-keymap (where)
 412   (setq where (or where (point)))
 413   (let* ((rec (get-char-property-and-overlay where 'keymap))
 414          (kmp (car rec))
 415          (ovl (cdr rec)))
 416     (when kmp
 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))
 423           ))))
 424
 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))))
 430
 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))))
 435
 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)
 443       (if old-wcfg
 444           (set-window-configuration old-wcfg)
 445         (help-xref-go-back (help-buffer))))))
 446
 447 (defun appmenu-as-help-in-timer (win buf)
 448   (condition-case err
 449       (when (and (eq (selected-window) win)
 450                  (eq (current-buffer) buf)
 451                  appmenu-auto-help
 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))))
 456           (unless old-help-win
 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)))))
 461
 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))
 466
 467 (defun appmenu-auto-help-post-command ()
 468   (when (fboundp 'appmenu-as-help)
 469     (condition-case err
 470         (appmenu-auto-help-post-command-1)
 471       (error (message "css-color-post-command: %s" (error-message-string err))))))
 472
 473 ;; #fff  #c9ff33
 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
 481                                   (selected-window)
 482                                   (current-buffer)))))
 483
 484
 485 ;;;###autoload
 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.
 492
 493 There is also the command `appmenu-as-help' that shows the key
 494 bindings at current point in the help buffer.
 495
 496 The popup menu and the help buffer version are on these keys:
 497
 498 \\{appmenu-mode-map}
 499
 500 The variable `appmenu-alist' is where the popup menu entries
 501 comes from.
 502
 503 If there is a `keymap' property at point then relevant bindings
 504 from this is also shown in the popup menu.
 505
 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."
 510   :global t
 511   :keymap appmenu-mode-map
 512   :group 'appmenu
 513   (if appmenu-mode
 514       (add-hook 'post-command-hook 'appmenu-auto-help-post-command)
 515     (remove-hook 'post-command-hook 'appmenu-auto-help-post-command)))
 516
 517 (when (and appmenu-mode
 518            (not (boundp 'define-globa-minor-mode-bug)))
 519   (appmenu-mode 1))
 520
 521 (provide 'appmenu)
 522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 523 ;;; appmenu.el ends here