menu interface for registers

[Masatake YAMATO]

I have thought register may be useful for ten years.
However it is not easy to use for me. One of the biggest reason is
that I cannot remember what I have stored to which register; register's 
size of emacs is enough but that of my brain is not enough.
Then I have written a menu interface for registers(regmenu.el).
I think it is worth to distribute regmenu.el with emacs.
I would like to have your comments.

Features:
- Used registers holding a point have menu items: "Jump to" and "Exchange Point 
with" with help-echo.
- Used registers holding text have menu items: "Insert String" and "Edit 
String" with help-echo.

Masatake YAMATO
-------------------------------------------------------------------------------------------
(Before trying, Please apply the patch I posted with Subject: "Using overlay in 
register".)
;; regmenu.el --- menu interface for registers.

(defgroup register-menu ()
  "Menu interface for registers."
  :group 'register
  :prefix "register-menu-")

(defcustom register-menu-position 'top-level
  "Register menu posiiton in menu bar."
  :group 'register-menu
  :type '(choice (const top-level) (const nested)))
  
(defvar register-menu-base-menu
  (let ((menu (make-sparse-keymap "Registers")))
    (define-key-after menu [point-to] 
      '(menu-item "Store Point to..." point-to-register))
    (define-key-after menu [copy-to] 
      '(menu-item "Store Text to..."  copy-to-register))
    (define-key-after menu [copy-rectangle-to]
      '(menu-item "Store Rectangle to..." copy-rectangle-to-register))
    menu))
  
(defun register-menu-clear-register (register)
  "Clear the contents of REGISTER."
  (interactive "cClear register: ")
  (set-register register nil))

(defun register-menu-exchange-point-and-register (register &optional delete)
  "Do `jump-to-register' and store the last point or window/frame configuration 
to REGISTER."
  (interactive "cExchange with register: \nP")
  (let ((val (get-register register)))
    (cond
     ((and (consp val) (frame-configuration-p (car val)))
      (frame-configuration-to-register register)
      (set-frame-configuration (car val) (not delete))
      (goto-char (cadr val)))
     ((and (consp val) (window-configuration-p (car val)))
      (window-configuration-to-register register)
      (set-window-configuration (car val))
      (goto-char (cadr val)))
     ((overlayp val)
      (or (overlay-buffer val)
          (error "That register's buffer no longer exists"))
      (setq val (copy-overlay val))
      (point-to-register register)
      (switch-to-buffer (overlay-buffer val))
      (goto-char (min (overlay-start val) (overlay-end val)))
      (delete-overlay val))
     (t
      (error "Register doesn't contain a buffer position or configuration")))))

(defun register-menu-edit-register (register)
  "Edit the text contents of REGISTER in minibuffer."
  (interactive "cEdit register: ")
  (let ((val (get-register register)))
    (unless (stringp val)
      (error "Register doesn't contain a string"))
    (set-register register (read-from-minibuffer 
                            (format "Edit text for register[%s]: "
                                    (single-key-description register))
                            val))))

;;
;; Dynamic menu items setup
;;
(defun register-menu-install-clear-item (menu key)
  (let ((action `(lambda () (interactive) 
                   (register-menu-clear-register ,key))))
    (define-key-after menu (make-vector 1 key)
      `(menu-item ,(single-key-description key) ,action))))

(defun register-menu-make-help-string-for-overlay (overlay)
  (let* ((buffer (overlay-buffer overlay))
         (pos (min (overlay-start overlay) (overlay-end overlay)))
         line contents whole-line)
    (save-excursion
      (set-buffer buffer)
      (goto-char pos)
      (setq line (count-lines (point-min) (point))
            contents (buffer-substring (line-beginning-position 0) 
                                       (line-end-position 2))
            whole-line (count-lines (point-min) (point-max)))
      (format 
       "Buffer: %s\nLine: %d(%d%%)\nLines Around the Register: \n%s"
       (buffer-name buffer)
       line 
       (/ (* line 100) whole-line)
       contents))))

(defun register-menu-install-overlay-item (menu key val)
  (let* ((action `(lambda ()(interactive) (jump-to-register ,key)))
         (help (register-menu-make-help-string-for-overlay val)))
    (define-key-after menu (make-vector 1 key)
      `(menu-item ,(single-key-description key) ,action :help ,help))))

(defun register-menu-install-exchange-item (menu key val)
  (let* ((action `(lambda ()(interactive) 
                    (register-menu-exchange-point-and-register
                     ,key)))
         (help (register-menu-make-help-string-for-overlay val)))
    (define-key-after menu (make-vector 1 key)
      `(menu-item ,(single-key-description key) ,action :help ,help))))

(defun register-menu-install-string-item (menu key val)
  (let ((action `(lambda ()(interactive) (insert-register ,key)))
        (help (format "Contents: \n%s" val)))
    (define-key-after menu (make-vector 1 key)
      `(menu-item ,(single-key-description key) ,action :help ,help))))

(defun register-menu-install-edit-item (menu key val)
  (let ((action `(lambda ()(interactive) (register-menu-edit-register ,key)))
        (help (format "Contents: \n%s" val)))
    (define-key-after menu (make-vector 1 key)
      `(menu-item ,(single-key-description key) ,action :help ,help))))

(defun register-menu-install-rectangle-item (menu key val)
  (register-menu-install-string-item menu key val))

(defun menu-bar-update-registers (&optional force)
  (let (register val
        (list (copy-sequence register-alist))
        (menu (copy-sequence register-menu-base-menu))
        (overlays-menu (make-sparse-keymap "Jump to"))
        (exchange-menu (make-sparse-keymap "Exchange Point with"))
        (strings-menu (make-sparse-keymap "Insert String"))
        (edit-menu    (make-sparse-keymap "Edit String"))
        (rectangles-menu (make-sparse-keymap "Insert Rectangle"))
        (clear-menu   (make-sparse-keymap "Clear")))
    (setq list (sort list (lambda (a b) (< (car a) (car b)))))
    (dolist (elt list)
      (setq register (car elt)
            val (get-register register))
      (when val
        (register-menu-install-clear-item clear-menu register)
        (cond
         ((and (overlayp val) (overlay-buffer val))
          (when (not (and (eq (current-buffer) (overlay-buffer val))
                        (eq (point) (min (overlay-start val)
                                         (overlay-end val)))))
            (register-menu-install-overlay-item
             overlays-menu register val)
            (register-menu-install-exchange-item
             exchange-menu register val)))
         ((stringp val)
          (register-menu-install-string-item
           strings-menu register val)
          (register-menu-install-edit-item
           edit-menu register val))
         ((and (consp val)
               (not (frame-configuration-p  (car val)))
               (not (window-configuration-p (car val))))
          (register-menu-install-rectangle-item
           rectangles-menu register val))
         )))
    (define-key menu [sep0] '("--"))
    (define-key menu [rectangles] `(menu-item 
                                    "Insert Rectangle"
                                    ,rectangles-menu
                                    :keys ,(substitute-command-keys 
"\\[insert-register]")
                                    :enable ,(< 2 (length rectangles-menu))))
    (define-key menu [edit] `(menu-item 
                              "Edit String"
                              ,edit-menu
                              :enable ,(< 2 (length edit-menu))))
    (define-key menu [strings] `(menu-item 
                                 "Insert String"
                                 ,strings-menu
                                 :keys ,(substitute-command-keys 
"\\[insert-register]")
                                 :enable ,(< 2 (length strings-menu))))
    (define-key menu [exchange] `(menu-item
                                  "Exchange Point with"
                                 ,exchange-menu
                                 :enable ,(< 2 (length exchange-menu))))
    (define-key menu [overlays] `(menu-item
                                 "Jump to"
                                 ,overlays-menu
                                 :keys ,(substitute-command-keys 
"\\[jump-to-register]")
                                 :enable ,(< 2 (length overlays-menu))))
    (define-key-after menu [sep2] '("--"))
    (define-key-after menu [clear] `(menu-item
                                     "Clear"
                                     ,clear-menu
                                     :enable ,(< 2 (length clear-menu))))
    (cond
     ((eq register-menu-position 'top-level)
      (define-key-after (current-global-map) [menu-bar register]
        (cons "Registers" menu)))
     ((eq register-menu-position 'nested)
      (define-key-after menu-bar-edit-menu [register]
        (cons "Registers" menu) 'bookmark)
      ))))

(add-hook 'menu-bar-update-hook 'menu-bar-update-registers)
(menu-bar-update-registers)

(provide 'regmenu)
;; regmenu.el ends here.