emacs/nxhtml/util/key-cat.el

   1 ;;; key-cat.el --- List key bindings by category
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Sat Jan 28 2006
   5 ;; Version: 0.25
   6 ;; Last-Updated: 2009-05-09 Sat
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;;   Requires Emacs 22.
  11 ;;
  12 ;; Features that might be required by this library:
  13 ;;
  14   ;; `cl'.
  15 ;;
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;;
  18 ;;; Commentary:
  19 ;;
  20 ;;  Display help that looks like a reference sheet for common
  21 ;;  commands.
  22 ;;
  23 ;;  To use this in your .emacs put
  24 ;;
  25 ;;    (require 'key-cat)
  26 ;;
  27 ;;  Then use the command
  28 ;;
  29 ;;    M-x key-cat-help
  30 ;;
  31 ;;  For more information see that command.
  32 ;;
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;;
  35 ;;; Change log:
  36 ;;
  37 ;;
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;;
  40 ;; This program is free software; you can redistribute it and/or modify
  41 ;; it under the terms of the GNU General Public License as published by
  42 ;; the Free Software Foundation; either version 2, or (at your option)
  43 ;; any later version.
  44 ;;
  45 ;; This program is distributed in the hope that it will be useful,
  46 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  47 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  48 ;; GNU General Public License for more details.
  49 ;;
  50 ;; You should have received a copy of the GNU General Public License
  51 ;; along with this program; see the file COPYING.  If not, write to the
  52 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  53 ;; Boston, MA 02111-1307, USA.
  54 ;;
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56 ;;
  57 ;;; Code:
  58
  59 (eval-when-compile (require 'cl))
  60
  61 (defconst key-cat-cmd-list
  62   '(
  63     (error-testing
  64      (commands
  65       :visible nil
  66       hallo
  67       key-cat-help
  68       key-cat-where-is
  69       ))
  70     ("Help"
  71      (commands
  72       help-for-help
  73       info-emacs-manual
  74       info
  75       ))
  76     ("Special Functions and Keys"
  77      ;; For similar functions that are most often bound to a specific key
  78      (commands
  79       key-cat-tab
  80       key-cat-complete
  81       )
  82      )
  83     ("Files, Buffers and Windows"
  84      (commands
  85       find-file
  86       save-buffer
  87       write-file
  88       split-window-vertically
  89       split-window-horizontally
  90       delete-other-windows
  91       other-window
  92       buffer-menu
  93       ))
  94     ("Search and replace"
  95      (commands
  96       isearch-forward
  97       isearch-backward
  98       query-replace
  99       isearch-forward-regexp
 100       isearch-backward-regexp
 101       query-replace-regexp
 102       occur
 103       lgrep
 104       rgrep
 105       ))
 106     ("Lines"
 107      (commands
 108       move-beginning-of-line
 109       move-end-of-line
 110       kill-line
 111       ))
 112     ("Words"
 113      (commands
 114       forward-word
 115       backward-word
 116       kill-word
 117       ))
 118     ("Region"
 119      (commands
 120       set-mark-command
 121       ;;cua-set-mark
 122       kill-region
 123       copy-region-as-kill
 124       yank
 125       yank-pop
 126       ))
 127     ("Undo"
 128      (commands
 129       undo
 130       ))
 131     ("Viper"
 132      (commands
 133       :visible (lambda()
 134                  (and (featurep 'viper)
 135                       viper-mode))
 136       viper-next-line
 137       viper-previous-line
 138       viper-forward-word
 139       viper-backward-word
 140       viper-forward-Word
 141       viper-backward-Word
 142       viper-repeat
 143       viper-forward-char
 144       viper-backward-char
 145       viper-next-line-at-bol
 146       viper-previous-line-at-bol
 147       viper-command-argument
 148       viper-digit-argument
 149       ))
 150     )
 151   "List with common commands to display by `key-cat-help'.
 152 The elements of this list corresponds to sections to show in the
 153 help.  Each element consists of sublists beginning with the
 154 keyword 'commands.  The sublists may after 'command contain the
 155 keyword :visible which takes a variable or function as argument.
 156 If the argument evaluates to non-nil the list is shown."
 157   )
 158
 159
 160 (defvar key-cat-cmd-list-1 nil)
 161
 162 (defun key-cat-help()
 163   "Display reference sheet style help for common commands.
 164 See also `key-cat-cmd-list'."
 165   (interactive)
 166   (if (> 22 emacs-major-version)
 167       (message "Sorry, this requires Emacs 22 or later")
 168     ;; Delay to get correct bindings when running through M-x
 169     (setq key-cat-cmd-list-1 key-cat-cmd-list)
 170     (run-with-timer 0.1 nil 'key-cat-help-internal)))
 171
 172 (defun key-cat-help-internal()                   ;(category)
 173   (message "Please wait ...")
 174   (condition-case err
 175       (save-match-data ;; runs in timer
 176         (let ((result))
 177           (help-setup-xref (list #'key-cat-help)
 178                            (interactive-p))
 179           ;;         (push (list "Changing commands"
 180           ;;                     (list
 181           ;;                      'command
 182           ;;                      indent-line-function
 183           ;;                      ))
 184           ;;               key-cat-cmd-list-1)
 185           (dolist (catentry key-cat-cmd-list-1)
 186             (let ((category (car catentry))
 187                   (commands (cdr catentry))
 188                   (cmds)
 189                   (keyw)
 190                   (visible)
 191                   (visible-fun)
 192                   (cmdstr)
 193                   (doc))
 194               (dolist (cmdlist commands)
 195                 (setq cmdlist (cdr cmdlist))
 196                 (setq visible t)
 197                 (while (keywordp (setq keyw (car cmdlist)))
 198                   (setq cmdlist (cdr cmdlist))
 199                   (case keyw
 200                     (:visible (setq visible-fun (pop cmdlist))
 201                               (setq visible (if (symbolp visible-fun)
 202                                                 (progn
 203                                                   (symbol-value visible-fun))
 204                                               (funcall visible-fun)))
 205                               )
 206                     ))
 207                 (when visible
 208                   (dolist (cmd cmdlist)
 209                     (setq cmds (cons cmd cmds)))))
 210               (when cmds
 211                 (push (format "\n%s:\n"
 212                               (let ((s (format "%s" category)))
 213                                 (put-text-property 0 (length s)
 214                                                    'face (list
 215                                                           'bold
 216                                                           )
 217                                                    s)
 218                                 s))
 219                       result))
 220               (setq cmds (reverse cmds))
 221               (dolist (cmd cmds)
 222                 (setq cmdstr
 223                       (let ((s "Where to find it:" ))
 224                         (put-text-property 0 (length s)
 225                                            'face '(:slant italic
 226                                                           :background "RGB:dd/dd/ff"
 227                                                           ) s) s))
 228                 (if (not (functionp cmd))
 229                     (cond
 230                      ((eq 'key-cat-tab cmd)
 231                       (let ((s "Indent line"))
 232                         (put-text-property 0 (length s) 'face '(:foreground "blue") s)
 233                         (push s result))
 234                       (push ":\n" result)
 235                       (push (concat
 236                              "    "
 237                              "Indent current line (done by specific major mode function).\n")
 238                             result)
 239                       (push (format "    %17s  %s\n" cmdstr (key-description [tab])) result)
 240                       )
 241                      ((eq 'key-cat-complete cmd)
 242                       (let ((s "Completion"))
 243                         (put-text-property 0 (length s) 'face '(:foreground "blue") s)
 244                         (push s result))
 245                       (push ":\n" result)
 246                       (push (concat
 247                              "    "
 248                              "Performe completion at point (done by specific major mode function).\n")
 249                             result)
 250                       (push (format "    %17s  %s\n" cmdstr (key-description [meta tab])) result)
 251                       )
 252                      (t
 253                       (let ((s (format "`%s':  (not a function)\n" cmd)))
 254                         (put-text-property 0 (length s) 'face '(:foreground "red") s)
 255                         (push s result))))
 256                   (let ((keys (key-cat-where-is cmd)))
 257                     (push (format "`%s':\n" cmd) result)
 258                     (setq doc (documentation cmd t))
 259                     (push
 260                      (concat
 261                       "    "
 262                       (if doc
 263                           (substring doc 0 (string-match "\n" doc))
 264                         "(not documented)")
 265                       "\n")
 266                      result)
 267                     (if (not keys)
 268                         (if (interactive-form cmd)
 269                             (push (format "    %17s  M-x %s\n" cmdstr cmd) result)
 270                           (let ((s "(not an interactive command)"))
 271                             (put-text-property 0 (length s) 'face '(:foreground "red") s)
 272                             (push (format "    %17s  %s\n" cmdstr s) result)))
 273                       (dolist (key keys)
 274                         (push (format "    %17s  " cmdstr) result)
 275                         (push (format "%s\n"
 276                                       (if (eq (elt key 0) 'xmenu-bar)
 277                                           "Menus"
 278                                         (key-description key)))
 279                               result)
 280                         (setq cmdstr ""))))))))
 281           (save-excursion
 282             (with-current-buffer (help-buffer)
 283               (with-output-to-temp-buffer (help-buffer)
 284                 (insert
 285                  (let ((s "Some important commands\n"))
 286                    (put-text-property 0 (length s)
 287                                       'face '(:weight bold
 288                                                       :height 1.5
 289                                                       :foreground "RGB:00/00/66") s)
 290                    s))
 291                 (setq result (reverse result))
 292                 (dolist (r result)
 293                   (insert r))
 294                 )))
 295           (message "")))
 296     (error (message "%s" (error-message-string err)))))
 297
 298 ;; Mostly copied from `where-is':
 299 (defun key-cat-where-is (definition)
 300   "Return key sequences that invoke the command DEFINITION.
 301 Argument is a command definition, usually a symbol with a function definition."
 302   (let ((func (indirect-function definition))
 303         (defs nil)
 304         (all-keys))
 305     ;; In DEFS, find all symbols that are aliases for DEFINITION.
 306     (mapatoms (lambda (symbol)
 307                 (and (fboundp symbol)
 308                      (not (eq symbol definition))
 309                      (eq func (condition-case ()
 310                                   (indirect-function symbol)
 311                                 (error symbol)))
 312                      (push symbol defs))))
 313     ;; Look at all the symbols--first DEFINITION,
 314     ;; then its aliases.
 315     (dolist (symbol (cons definition defs))
 316       (let* ((remapped (command-remapping symbol))
 317              (keys (where-is-internal
 318                     ;;symbol overriding-local-map nil nil remapped)))
 319                     symbol nil nil nil remapped)))
 320         (when keys
 321           (dolist (key keys)
 322             (setq all-keys (cons key all-keys))))))
 323     all-keys))
 324
 325
 326
 327 (provide 'key-cat)
 328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 329 ;;; key-cat.el ends here