2011年10月5日水曜日

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))))

0 件のコメント:

コメントを投稿