popup.elで遊んでみる

overlayを使ってポップアップメニューを表示するpopup.elを使ってみました。
rclk:rclkコマンドを実行すると、*rckl:clauses*に設定されている条件に
したがってメニューを表示します。

右クリックをイメージしています。

;; (require 'popup)

(defvar *rclk:clauses* nil)

(defvar *rclk:format-function* nil)

(defun rclk:rclk ()
(interactive)
(rclk:popup-menu*
(rclk:select *rclk:clauses*)))

(defun rclk:clause-name (clause)
(if (<= (length clause) 2)
   (second clause)
 (third clause)))

(defun rclk:select (clauses)
(let ((result nil))
 (dolist (c clauses)
   (let ((strs (funcall (first c))))
     (unless (listp strs)
       (setf strs (list strs)))
     (dolist (s strs)
       (push (list s (second c) (third c)) result))))
 (nreverse result)))

(defun rclk:popup-menu* (clauses)
(when clauses
 (let ((popup-clauses (mapcar 'rclk:clause->popup clauses)))
   (let ((result (popup-menu* (mapcar 'first popup-clauses))))
 (when result
       (let ((selected (find result popup-clauses
                             :key 'first
    :test 'string-equal)))
         (funcall (third selected) (second selected))
         t))))))

(defun rclk:clause->popup (clause)
(let ((str (substring-no-properties
           (funcall *rclk:format-function* clause))))
 (cons str clause)))

;;; test
(defun symbol-at-point-as-str ()
(when (symbol-at-point)
 (symbol-name (symbol-at-point))))
(defun find-function-from-str (str)
(find-function (intern str)))

;; clause = (文字列のリストを返す関数 選択時に呼び出される関数 表示項目名)
(setf *rclk:clauses*
   `((word-at-point apropos "apropos")
     (symbol-at-point-as-str find-function-from-str "find-function")))

(setf *rclk:format-function*
   (lambda (clause)
     (format "<%s> %s"
             (rclk:clause-name clause)
             (first clause))))