v 0. Pasted by Anonymous as lisp at 2011-10-18 04:37:08 MSK and set expiration to never.
v 1. Edited by Anonymous as lisp at 2011-10-23 22:32:01 MSK and set expiration to never.
v 2. Edited by desudesudesu as lisp at 2011-10-23 22:34:28 MSK and set expiration to never.
v 3. Edited by desudesudesu as lisp at 2011-11-10 02:42:16 MSK and set expiration to never.

Paste will expire never.

  1. ;; (defvar read-key-sequence-last-command-vector
  2. ;;   nil
  3. ;;   "Command vector we get before entered `read-key-sequence'. nil if we are not in `read-key-sequence'.")
  4.  
  5. ;; (defadvice read-key-sequence (before save-last-this-command-keys-vector)
  6. ;;   "Save last `this-command-keys-vector' so it can be accesible when reading."
  7. ;;   (setq read-key-sequence-last-command-vector (this-command-keys-vector)))
  8.  
  9. ;; (defadvice read-key-sequence (after clear-last-this-command-keys-vector)
  10. ;;   "Clear last `this-command-keys-vector' so we know that `read-key-sequence' is not active."
  11. ;;   (setq read-key-sequence-last-command-vector nil))
  12.  
  13. ;; (ad-activate 'read-key-sequence)
  14.  
  15. (defvar keylist-format-strings-priority-list
  16.   '(major-bindings-string
  17.      global-bindings-string
  18.      minor-bindings-string
  19.      translation-bindings-string
  20.      function-key-bindings-string)
  21.   "This variable is used to determine priority, in which bindings should be inserted.
  22. Must be list with any of this symbols:
  23. major-bindings-string
  24. global-bindings-string
  25. minor-bindings-string
  26. translation-bindings-string
  27. function-key-bindings-string")
  28.  
  29. (defvar keylist-minibuffer-heights
  30.   1
  31.   "How much vertical space are given. Default to 1.")
  32.  
  33. (defvar keylist-maximum-lenght
  34.   6
  35.   "Maximum lenght of left OR right side for some function. If variable value = 5, output will be given like xxxxx<number>xxxxx")
  36.  
  37. (defvar keylist-font-function-text
  38.   'font-lock-string-face
  39.   "Font for function text")
  40.  
  41. (defvar keylist-font-attributes-function-number
  42.   'font-lock-constant-face
  43.   "Font for function shorten number")
  44.  
  45. (defvar keylist-font-keys-pressed
  46.   'font-lock-function-name-face
  47.   "Font for keys that is actually pressed at the moment")
  48.  
  49. (defvar keylist-font-prefix-key
  50.   'font-lock-preprocessor-face
  51.   "Font for prefix arg")
  52.  
  53. (defvar keylist-font-global-string
  54.   'font-lock-keyword-face
  55.   "Font for global bindings key sequence")
  56.  
  57. (defvar keylist-font-major-string
  58.   'font-lock-type-face
  59.   "Font for major bindings key sequence")
  60.  
  61. (defvar keylist-font-minor-string
  62.   'font-lock-comment-face
  63.   "Font for minor bindings key sequence")
  64.  
  65. (defvar keylist-font-translation-string
  66.   'font-lock-builtin-face
  67.   "Font for font transtation bindings key sequence")
  68.  
  69. (defvar keylist-font-function-key-string
  70.   'font-lock-builtin-face
  71.   "Font for key key sequence bindings key sequence")
  72.  
  73. (defvar keylist-font-prefix-key
  74.   'font-lock-warning-face
  75.   "Font for prefix key")
  76.  
  77. (defun keylist-format-buffer-function(key-string)
  78.   "This function transforms raw `describe-buffer-bindings' output into nice informative line.
  79. It works in temporary buffer. The result is left in that buffer.
  80. This function returns nil.
  81. KEY-STRING is string value, given by `(key-description (this-command-keys-vector))'."
  82.   (let ( global-bindings-string
  83.          major-bindings-string
  84.          minor-bindings-string
  85.          translation-bindings-string
  86.          function-key-bindings-string)
  87.    
  88.     (goto-char 1)
  89.     (when (search-forward "Global Bindings Starting With" (point-max) t)
  90.       (forward-line 4)
  91.       (let ((beg (point)))
  92.         (goto-char (or (search-forward " " (point-max) t) (point-max)))
  93.         (forward-line -1)
  94.         (setq global-bindings-string (buffer-substring-no-properties beg (point)))))
  95.  
  96.     (goto-char 1)
  97.     (when (search-forward "Major Mode Bindings Starting With" (point-max) t)
  98.       (forward-line 4)
  99.       (let ((beg (point)))
  100.         (goto-char (or (search-forward " " (point-max) t) (point-max)))
  101.         (forward-line -1)
  102.         (setq major-bindings-string (buffer-substring-no-properties beg (point)))))
  103.  
  104.     (goto-char 1)
  105.     (when (search-forward "Minor Mode Bindings Starting With" (point-max) t)
  106.       (forward-line 4)
  107.       (let ((beg (point)))
  108.         (goto-char (or (search-forward " " (point-max) t) (point-max)))
  109.         (forward-line -1)
  110.         (setq minor-bindings-string (buffer-substring-no-properties beg (point)))))
  111.  
  112.     (goto-char 1)
  113.     (when (search-forward "Key translations Starting With" (point-max) t)
  114.       (forward-line 4)
  115.       (let ((beg (point)))
  116.         (goto-char (or (search-forward " " (point-max) t) (point-max)))
  117.         (forward-line -1)
  118.         (setq translation-bindings-string (buffer-substring-no-properties beg (point)))))
  119.  
  120.     (goto-char 1)
  121.     (when (search-forward "Function key map translations Starting With" (point-max) t)
  122.       (forward-line 4)
  123.       (let ((beg (point)))
  124.         (goto-char (or (search-forward " " (point-max) t) (point-max)))
  125.         (forward-line -1)
  126.         (setq function-key-bindings-string (buffer-substring-no-properties beg (point)))))
  127.  
  128.     (erase-buffer)
  129.  
  130.     (mapcar*
  131.       (lambda(arg key-string)
  132.         (let ((x (eval arg)) spl1 spl2 (spl3 "")(i 0))
  133.           (when x
  134.             (setq spl1 (split-string x "\n" t))
  135.             (while spl1
  136.               (setq spl2 `(,@spl2 ,(split-string (car spl1) " \\{2,\\}" t)) spl1 (cdr spl1)))
  137.             (while spl2
  138.               (setq spl3 (concat spl3
  139.                            (let ((firstpart
  140.                                    (replace-regexp-in-string " " ""
  141.                                      (replace-regexp-in-string
  142.                                        (concat "^" (regexp-quote key-string)) ""
  143.                                        (caar spl2)))))
  144.                              (if (string= (cadar spl2) "Prefix Command")
  145.                                (propertize firstpart 'face keylist-font-prefix-key)
  146.                                (concat (propertize firstpart 'face (cond
  147.                                                              ((eq arg 'global-bindings-string) keylist-font-global-string)
  148.                                                              ((eq arg 'major-bindings-string) keylist-font-major-string)
  149.                                                              ((eq arg 'minor-bindings-string) keylist-font-minor-string)
  150.                                                              ((eq arg 'translation-bindings-string) keylist-font-translation-string)
  151.                                                              ((eq arg 'function-key-bindings-string) keylist-font-function-key-string)))
  152.                                  (if (> (length (cadar spl2)) (+ (* 2 keylist-maximum-lenght) 1))
  153.                                    (concat
  154.                                      (propertize (substring (cadar spl2) 0 keylist-maximum-lenght)
  155.                                        'face keylist-font-function-text)
  156.                                      (propertize
  157.                                        (format "%d" (- (length (cadar spl2)) (* 2 keylist-maximum-lenght)))
  158.                                        'face keylist-font-attributes-function-number)
  159.                                      (propertize (substring (cadar spl2) (- keylist-maximum-lenght))
  160.                                        'face keylist-font-function-text))
  161.                                    (propertize (cadar spl2)
  162.                                      'face keylist-font-function-text))))))
  163.                 spl2 (cdr spl2)))
  164.             (insert spl3)
  165.             spl3)))
  166.       keylist-format-strings-priority-list
  167.       (make-list (length keylist-format-strings-priority-list) key-string)))
  168.   nil)
  169.  
  170. (defun keylist-function()
  171.   ;; (when (and (= 0 (length (this-command-keys-vector))))
  172.   ;;   (setq keylist-last-message (or cursor-in-echo-area (minibufferp))))
  173.   (when
  174.     (and
  175.       (/= 0 (length (this-command-keys-vector)))
  176.       (or
  177.         (and
  178.           (boundp 'keylist-last-vector)
  179.           (not (equal keylist-last-vector (this-command-keys-vector))))
  180.         (not (string=
  181.                (save-excursion
  182.                  (set-buffer " *Echo Area 0*")
  183.                  (buffer-substring-no-properties (point-min) (point-max)))
  184.                keylist-last-message)))
  185.       (not cursor-in-echo-area)
  186.       (not (minibufferp))
  187.       (not (= 13 (aref (this-command-keys-vector) 0)))
  188.  
  189.       ;; (not read-key-sequence-last-command-vector)
  190.  
  191.       ;; (or (not keylist-last-message)
  192.       ;;   (string=
  193.       ;;     keylist-last-message
  194.       ;;     (save-excursion
  195.       ;;       (set-buffer " *Echo Area 0*")
  196.       ;;       (buffer-substring-no-properties (point-min) (point-max)))))
  197.       )
  198.     ;; (setq x (cons (save-window-excursion (select-window (minibuffer-window)) (minibuffer-prompt)) x))
  199.     ;; (setq keylist-last-minibuffer-string (with-current-buffer (window-buffer (active-minibuffer-window)) (minibuffer-contents)))
  200.     (let ((buf (current-buffer)) (minibuffer-message-timeout nil) (message-log-max nil))
  201.       (with-current-buffer (get-buffer-create " *keylist*")
  202.         (erase-buffer)
  203.         (describe-buffer-bindings buf (this-command-keys-vector))
  204.         (keylist-format-buffer-function (key-description (this-command-keys-vector)))
  205.         (message "%s"
  206.           (let ((output-string
  207.                   (concat
  208.                     (propertize
  209.                                   (cond
  210.                                     ((eq '- prefix-arg) "- ")
  211.                                     ((and prefix-arg (listp prefix-arg)) "u ")
  212.                                     ((numberp prefix-arg) (format "%d " prefix-arg))
  213.                                     (t ""))
  214.                       'face keylist-font-prefix-key)
  215.                     (propertize
  216.                       (key-description (this-command-keys-vector))
  217.                       'face keylist-font-keys-pressed)
  218.                     " "
  219.                     (buffer-substring 1 (point-max))
  220.                     )))
  221.             (substring output-string
  222.               0 (min (length output-string) (* keylist-minibuffer-heights (window-width (minibuffer-window)))))))))
  223.     (setq keylist-last-message
  224.       (save-excursion
  225.         (set-buffer " *Echo Area 0*")
  226.         (buffer-substring-no-properties (point-min) (point-max))))
  227. )
  228.   (setq keylist-last-vector (this-command-keys-vector)))
  229.  
  230.  
  231. (defun keylist (&optional arg)
  232.   "This function run idle timer function.
  233. With any arg cancels current active `keylist-timer', if any.
  234. With ARG t `run-with-idle-timer' `keylist-timer'.
  235. Returns timer.
  236. Usage: copy this to your .emacs file (keylist t)"
  237.   (interactive "P")
  238.   (if (boundp 'keylist-timer)
  239.     (cancel-timer keylist-timer))
  240.   (when arg
  241.     (setq keylist-timer
  242.       ;; (run-with-idle-timer 0.1 t
  243.       (run-with-timer 0 0.05
  244.         'keylist-function))))
  245.  
  246. (defun keylist-newbie-settings(&optional arg)
  247.   "Set `keylist-minibuffer-heights' and `keylist-maximum-lenght', nothing more.
  248. With ARG t set values, better suitable for novices (longer function names, more verticall space).
  249. With ARG nil set default values, more safe values.
  250. Usage: copy this to your .emacs file (keylist-newbie-settings t)"
  251.   (interactive "P")
  252.   (if arg
  253.     (progn
  254.       (setq keylist-minibuffer-heights 7)
  255.       (setq keylist-maximum-lenght 15))
  256.     (progn
  257.       (setq keylist-minibuffer-heights 1)
  258.       (setq keylist-maximum-lenght 6)))
  259.   arg)
  260.  
  261. (provide 'keylist)
  262. ;; (keylist t)
  263. ;; (keylist-newbie-settings t)
  264.