refer-for で定義元のソースにジャンプ

refer-for で、

[File ]: なんちゃら.l

の行で enter 押すとそのファイルを開いて、定義の箇所を見れるようにした。

今のところ、対応しているのは下記だけ。

• 関数名


• 変数名


• マクロ名

(defvar *refer-for-jump-dir* `(,(merge-pathnames "lisp" (si:system-root))
,(merge-pathnames "site-lisp" (si:system-root)))
"reference の `File' の欄から *.l を検索するとき、検索対象のディレクトリを指定する。")

(defvar *refer-for-jump-file-read-only* t
"reference の `File' の欄から *.l を開くとき、read-only にするかどうかを指定する。
nil なら普通に開く。non-nil なら read-only で開く。")

(defvar refer-for-jump-file-alist
'(("Accessor"     . 'ignore)
("BufferLocal"  . 'ignore)
("Keyword"      . 'ignore)
("Macro"        . "^[ \t]*\([ \t]*defmacro[ \t]+XXNAMEXX[ \t]+\(") ; 改行も
("Misc"         . 'ignore)
("Special Form" . 'ignore)
("Struct"       . "^[ \t]*\([ \t]*defstruct[ \t]+\([ \t]*XXNAMEXX[ \t]+")
("Tips"         . 'ignore)
("Variable"     . "^[ \t]*\([ \t]*defvar[ \t]+XXNAMEXX[ \t]+")
("Function (interactive)" . "[ \t]*\([ \t]*defun[ \t]+XXNAMEXX[ \t]+")
("Function"     . "[ \t]*\([ \t]*defun[ \t]+XXNAMEXX[ \t]+"))
"`Type'欄と、それをソースファイルから検索するときの正規表現テンプレートの alist。'ignore は「今のところ無視する」という印。")

(defvar refer-for-jump-content-alist '((type    . "^\\[Type       \\]: \\(.+\\)$")
(name    . "^■\\(.+\\)$"))
"*Reference*バッファの欄のシンボルとその検索に使う正規表現の alist")


(defun refer-for-jump-get-content ()
"ポイントが *Reference*バッファの`File'欄や`Type'欄の行にある場合、
欄のシンボルとその後ろの文字列を取得し、多値で返す。見つけられなかった場合は nil を返す。
例: 見つけた場合こんなのを返す 'seealso と \"buffer-read-only\""
(let ((lim (save-excursion (progn (goto-eol) (point)))))
(save-excursion
(goto-bol)
(if (scan-buffer "^\\[\\(.+\\) *\\]: *\\(.*\\)$" :regexp t :limit lim)
(let ((desc (string-trim " \t" (match-string 2)))
(header (intern (nstring-downcase (substitute-string (match-string 1) "[ \t]+" "")))))
(values header desc))))))

(defun refer-for-jump-get-desc-at-point (sym)
"現在参照中のリファレンス項目の 文字列を取得する。
例: 'type --> \"Function (interactive)\" を返す。"
(let ((re (cdr (assoc sym refer-for-jump-content-alist))))
(save-excursion
(when (scan-buffer re :regexp t :reverse t)
(string-trim " \t" (match-string 1))))))

(defun refer-for-jump-file (file)
"reference の `File'欄から定義元のソースファイルを開く。"
(flet ((get-file-path (name)
(find-path-from-top-directory name *refer-for-jump-dir*)))
(let* ((type (refer-for-jump-get-desc-at-point 'type))
(name (refer-for-jump-get-desc-at-point 'name))
(re-template (cdr (assoc type refer-for-jump-file-alist :test #'string=))))
(cond ((null file))
((string= file "builtin.l") (error "ビルトイン関数なので開きません。"))
((null name) (error "reference の 項目名が見つかりません。"))
((null type) (error "reference の Type が見つかりません。"))
((null re-template) (error "Type: ~A には未対応です。" type))
((eq re-template 'ignore))
(t
(let* ((path (get-file-path file))
(buf-new (ed::find-file-internal path)))
(set-buffer buf-new)
(when *refer-for-jump-file-read-only*
(setq buffer-read-only t))
(let ((re (substitute-string re-template "XXNAMEXX" name)))
(unless (scan-buffer re :regexp t)
(delete-buffer buf-new)
(error "定義元が見つかりませんでした。")))))))))

(defun refer-for-jump-seealso (name)
"オリジナルの refer-for-search-seealso とだいたい同機能 (ただし、re は無効)"
(let ((str (format nil "^~A$" (regexp-quote name))))
(refer-for::output (refer-for::search str :by-title t))
(refer-for::set-history str t)))

;;; command
(defun refer-for-jump ()
"ポイントがある行によって、いろんなところへ飛ぶ。
`File'欄にあるときは、ソースファイルを検索する (refer-for-jump-file)
`See also'欄にあるときは、そのリファレンス項目に移動する (refer-for-jump-seealso)"
(interactive)
(multiple-value-bind (header desc) (refer-for-jump-get-content)
(case header
('seealso (refer-for-jump-seealso desc))
('file (refer-for-jump-file desc)))))

(define-key refer-for::*refer-for-mode-map* #\RET 'refer-for-jump)

ほんのすこし doc-string を書く努力をしようと思った。