[RFC] clickable text and context menu for keyboard operation

[Masatake YAMATO]

In my understanding clickable text and popup menu of emacs are for
mouse users. I guess most of you use emacs with keyboard. Therefore
most of you don't receive the benefits of them.  *CPP Edit* buffer
created by M-x cpp-highlight-buffer is typical example. With mouse you
can choose the face for the cpp condition represented by the buffer
position. However, with keyboard you have to give the cpp condition
from minibuffer even the point specifies the cpp condition.

We can make clickable text and popup menu useful even for keyboard 
users with adding some lisp APIs.

I'd like propose two API sets here. I'd like to get comments.

1. clickable text sensitive to point movement
-----------------------------------------------------------

With mouse you can recognized there is a clickable text or popup menu
because it is highlighted when moving the mouse cursor on the area. In
other hand, when moving the point to the area, nothing happens in
many cases because `point-entered' handler for the area isn't
implemented.  What handler has to do is simple: highlighting the area.
I think it is nice to provide such common required function as part of
emacs.

`point-highlight'

        New face for highlighting the area when point enters to it.

`highlight-text-when-point-entered'

        Handler for `point-entered' prop to highlight the area
        when the point enters to it.

`unhighlight-text-when-point-left'

        Handler for `point-left' prop to unhighlight the area
        when the point left it.

`point-help-echo'

        New property whose value is used as tooltip text when
        the point enter to the area.

2. context menu activated by keyboard operation
-----------------------------------------------------------
With the above API, user can know there is something under
the point. Following API is for the case that the "something"
is a popup menu.

`popup-context-menu-with-key'

        A function picking up the menu definition embedded as a value
        for `context-meun' prop under the point; and showing it.

`popup-context-menu-with-mouse'
 
        This is a bonus function:)

User interaface
-----------------------------------------------------------

In my example `popup-context-menu-with-key' is bound to [f9].
But my private favorite is \C-j. How do you think?

Testing
-----------------------------------------------------------
Eval attached code and do M-x context-menu-test.
This works even on terminal if you are using the latest emacs!



;;
;; context-menu.el
;;

;; semantic-displayor-tooltip-show is used to show tooltip.
(require 'semantic/complete)

;; Just copied from highlight face.
(defface point-highlight
  '((((class color) (min-colors 88) (background light))
     :background "darkseagreen2")
    (((class color) (min-colors 88) (background dark))
     :background "darkolivegreen")
    (((class color) (min-colors 16) (background light))
     :background "darkseagreen2")
    (((class color) (min-colors 16) (background dark))
     :background "darkolivegreen")
    (((class color) (min-colors 8))
     :background "green" :foreground "black")
    (t :inverse-video t))
  "Basic face for indicating the area where a context-menu is embedded."
  :group 'basic-faces)


(defun highlight-text-when-point-entered (old new)
  "Highlight the clickable area.
This function is assumed to be used as callback function for 
`point-entered' text property.
A tooltip given with `point-help-echo' property is also shown
in this function."
  ;; For debugging.
  ;; (message "enter %d->%d" old new)
  (let ((buffer-read-only nil))
    ;; Reset the face of area around old was.
    (let* ((current-face (get-text-property old 'face))
           (current-font-lock-face (get-text-property old 'font-lock-face))
           (original-face (get-text-property old 'original-face))
           (original-font-lock-face (get-text-property old 
'original-font-lock-face))
           (e (or (next-single-property-change old 'point-face)
                  (point-max)))
           (b (or (previous-single-property-change e 'point-face)
                  (point-min)))) 
      (unless (equal original-face current-face)
        (put-text-property b e 'face original-face))
      (unless (equal original-font-lock-face current-font-lock-face)
        (put-text-property b e 'font-lock-face original-font-lock-face)))
    ;; Set the face of area around new is.
    (let* ((current-face (get-text-property new 'face))
           (current-font-lock-face (get-text-property new 'font-lock-face))
           (new-face (get-text-property new 'point-face))
           (e (or (next-single-property-change new 'point-face)
                  (point-max)))
           (b (or (previous-single-property-change e 'point-face)
                  (point-min))))
      (when new-face
        (unless (equal current-face new-face)
          (put-text-property b e 'original-face current-face)
          (put-text-property b e 'face new-face))
        (unless (equal current-font-lock-face new-face)
          (put-text-property b e 'original-font-lock-face 
current-font-lock-face)
          (put-text-property b e 'font-lock-face new-face))))
    (let ((m (get-text-property new 'point-help-echo)))
      (setq m (cond
               ((and (not m)
                     (get-text-property new 'context-menu))
                (format "%s shows context-menu" 
                        (where-is-internal 'popup-context-menu-with-key)))
               ((eq m t)
                (get-text-property new 'help-echo))
               (t m)))
      (when m 
        (semantic-displayor-tooltip-show m)))))

(defun unhighlight-text-when-point-left (old new)
  "Unhighlight the clickable area.
This function is assumed to be used as callback function for 
`point-left' text property."
  ;; For debugging.
  ;; (message "left %d->%d" old new)
  (let ((buffer-read-only nil))
    (let* ((original-face (get-text-property old 'original-face))
           (original-font-lock-face (get-text-property old 
'original-font-lock-face))
           (current-face (get-text-property old 'face))
           (current-font-lock-face (get-text-property old 'font-lock-face))
           (e (or (next-single-property-change old 'point-face)
                  (point-max)))
           (b (or (previous-single-property-change e 'poinst-face)
                  (point-min))))
      (unless (eq original-face current-face)
        (put-text-property b e 'face original-face))
      (unless (eq original-font-lock-face current-font-lock-face)
        (put-text-property b e 'font-lock-face original-font-lock-face)))))

(define-key global-map [f9] 'popup-context-menu-with-key)
(defun popup-context-menu-with-key ()
  "Popup context menu under the point.
This function picks up the menu definition embedded as a value
for `context-meun' property under the point; and show it.
The definition must be a value acceptable to the fist argument
of `popup-menu'. However, if the definition is a function, the
function is called and the value returned from the function call is
used as argument for `popup-menu'."
  (interactive)
  (let ((cmenu (get-text-property (point) 'context-menu)))
    (if cmenu
        (popup-menu (if (functionp cmenu) 
                        (funcall cmenu 'key) 
                      cmenu) 
                    last-nonmenu-event)
      (error "No context menu here"))))

(define-key global-map [S-down-mouse-2] 'popup-context-menu-with-mouse)
(defun popup-context-menu-with-mouse (event)
  "Popup context menu embedded at the place where mouse event emits."
  (interactive "e")
  (let* ((window (posn-window (event-end event)))
         (pos (posn-point (event-end event)))
         cmenu)
    (unless (windowp window)
      (error "Unexpected area"))
    (with-current-buffer (window-buffer window)
      (setq cmenu (get-text-property pos 'context-menu))
      (if cmenu
          (progn
            (goto-char pos)
            (redisplay)
            (popup-menu (if (functionp cmenu) 
                            (funcall cmenu 'mouse) 
                          cmenu) 
                        event))
        (error "No context menu here")))))

;;
;; For testing
;; 
(defun context-menu-test ()
  "Test code for context-menu concept."
  (interactive)
  (let ((b (get-buffer-create "*context-menu-test*")))
    (set-buffer b)
    (erase-buffer)
    (insert (format "[%s]\n"
                    (propertize (copy-sequence "MENU OBJECT")
                                'point-entered 
'highlight-text-when-point-entered
                                'point-left 'unhighlight-text-when-point-left
                                'point-face 'point-highlight
                                'point-help-echo "A context menu is embed"
                                'context-menu menu-bar-file-menu
                                )))
    (insert (format "[%s]\n"
                    (propertize (copy-sequence "FUNCTION")
                                'point-entered 
'highlight-text-when-point-entered
                                'point-left 'unhighlight-text-when-point-left
                                'point-face 'point-highlight
                                'point-help-echo "Another context menu is embed"
                                'context-menu (lambda (device) 
menu-bar-file-menu)
                                )))
    (insert (format "[%s]\n"
                    (propertize (copy-sequence "DEFAULT TOOLTIP")
                                'point-entered 
'highlight-text-when-point-entered
                                'point-left 'unhighlight-text-when-point-left
                                'point-face 'point-highlight
                                'context-menu menu-bar-file-menu)))
    (goto-char (point-min))
    (pop-to-buffer b)))

(provide 'context-menu)