popup.elで右クリックのようななにか

popup.elでコマンドメニューを表示させてみます。

(require 'popup)

(defvar *rclick-command-tree*)

(setf *rclick-command-tree*
      `(
	[org-capture "org-capture" (lambda () (featurep 'org))]
	("Erlang"
	 [:major-mode erlang-mode]
	 [run-erlang "run-erlang-shell"])
	("Org"
	 [:feature org]
	 [org-sparse-tree "org-sparse-tree"]
	 [org-schedule "org-schedule"]
	 [org-deadline "org-deadline"]
	 [org-time-stamp "org-time-stamp"])
	("VC"
	 ;; vc-annotate (C-x v g) 注釈を表示
	 [vc-annotate "vc-annotate"]
	 ;; vc-diff (C-x v =) 差分を表示
	 [vc-diff "vc-diff"]
	 ;; vc-dir (C-x v d) 状態を表示
	 [vc-dir "vc-dir"]
	 ;; vc-print-log (C-x v l) 履歴を表示
	 [vc-print-log "vc-print-log"]
	 ;; vc-register (C-x v i) ファイルを追加
	 [vc-register "vc-register"]
	 ;; vc-revert (C-x v u) 修正を破棄
	 [vc-revert "vc-revert"]
	 ;; vc-update (C-x v +) 後進
	 [vc-update "vc-update"]
	 ;; vc-next-action (C-x v v) コミット
	 [vc-next-action "vc-next-action(commit)"]
	 ;; vc-revision-other-window (C-x v ~) 過去のバージョンを表示
	 [vc-revision-other-window "vc-revision-other-window"])))

(defun rclick-tree-normalize (tree)
  (mapcar
   (lambda (s)
     (typecase s
       (cons (rclick-tree-normalize s))
       (symbol [s (format "%s" s)])
       (string s)
       (vector (if (>= (length s) 2) s
		 [(aref s 0) (format "%s" (aref s 1))]))
       (t (error "invalid tree"))))
   tree))

(defun rclick-collect-test (tree)
  (remove-if-not
   (lambda (c)
     (and (typep c 'vector)
	  (keywordp (aref c 0))))
   tree))

(defun rclick-tree-collect (tree)
  (let ((tests (rclick-collect-test tree)))
    (when (every 'rclick-test tests)
      (let ((result nil))
	(dolist (c tree)
	  (cond
	   ((and (typep c 'vector)
		 (not (keywordp (aref c 0))))
	    (when (or (<= (length c) 2)
		      (funcall (aref c 2)))
	      (push c result)))
	   ((listp c)
	    (let ((children (rclick-tree-collect c)))
	      (when children
		(push children result))))
	   ((stringp c)
	    (push c result))
	   (t 'nothing-to-do)))
	(nreverse result)))))

(defun rclick-tree->cascade-menu (tree)
  (mapcar
   (lambda (c)
     (typecase c
       (vector (format "%s" (aref c 1)))
       (cons (rclick-tree->cascade-menu c))
       (t c)))
   tree))

(defun rclick-find (desc tree)
  (dolist (c tree)
    (when (and (typep c 'vector)
	       (string-equal desc (aref c 1)))
      (return c))
    (when (listp c)
      (let ((tmp (rclick-find desc c)))
	(when tmp
	  (return tmp))))))

(defun rclick-test (vec)
  (apply (get (aref vec 0) 'rclick-test-function)
	 (cdr (coerce vec 'list))))

(defmacro define-rclick-test (key args &rest body)
  `(setf (get ',key 'rclick-test-function) (lambda ,args ,@body)))

(define-rclick-test :major-mode (mode)
  (eq mode major-mode))
(define-rclick-test :feature (feature)
  (featurep feature))

(defun rclick-menu ()
  (interactive)
  (let ((tree (rclick-tree-collect
	       (rclick-tree-normalize *rclick-command-tree*))))
    (let ((result (popup-cascade-menu (rclick-tree->cascade-menu tree))))
      (when result
	(let ((c (rclick-find result tree)))
	  (when c
	    (call-interactively (aref c 0))))))))

おまけ。コマンドのキーバインドを文字列で取得する方法。

(defun one-of-bindings (command)
  (key-description (car (where-is-internal command))))