正規表現の色分け

■正規表現の色分け
pickup-patternとre-builderのどちらかを使って正規表現の色分けをC-s中にやらせようかと思って見たりしたので色々調べた感じ。
　pickup-patternはグループごとの色分けがUIとしては付いてないので、自分でグループ訳とかして塗らないといけないので色々と面倒が多そう。後、基本的に関数が引数貰ってくれないようなつくりが多いので、結構変えないと駄目かも。
　re-builderはグループの色分けが元々あって正規表現の色分け的には申し分ないのだけど、ソースがちょっと難しい感じというか、Windowの配置とかバッファの設定とかのUI部分が結構色々動いているので、そこから色分けの部分だけを流用するのが難しいと言うか。

■具体的にやった事
　出来ればre-builderの色分けを使いたかったので、中から色分けの部分だけ抜き出して、引数でもらったregexpで色を付けるのを試した。コードはre-builderに依存するとre-builderの挙動がおかしくなってしまいそうだったので、共存できるように少々重複しても無視して独立してても利用できるようにしたつもり。色分けの方法はre-builderと全く同じというか、コードそのものパクリ。

(defvar *regexp-auto-match-limit* 200 "色分けの最大数？だと思う")
(defvar *regexp-color-tag* 'regexp-color-tag "色分けする時に付けるタグ")
(defvar *regexp-match-attributes*
  '((:bold t :foreground 1 :background 2)
    (:bold t :foreground 1 :background 3)
    (:bold t :foreground 1 :background 4)
    (:bold t :foreground 1 :background 5)
    (:bold t :foreground 1 :background 6)
    (:bold t :foreground 1 :background 7)
    (:bold t :foreground 1 :background 8)
    (:bold t :foreground 1 :background 9)
    (:bold t :foreground 1 :background 10)
    (:bold t :foreground 1 :background 11))
  "Used for displeaying.")

;; coloring core
(defun pickup-regexp (regexp &optional subexp)
"regexp coloring"
  (interactive "sRegexp : ")
  (let* ((subexps (regexp-color-count-subexps regexp))
		 (matches 0)
		 (submatches 0)
		 firstmatch)
	(save-excursion
	  (if (find-text-attribute *regexp-color-tag*)
		  (delete-text-attributes *regexp-color-tag*))
	  ;(goto-char (point-min));;汎用性落ちそうなのでこれはコメントアウトしてみた
	  (while (and (scan-buffer regexp
							   :case-fold *case-fold-search*
							   :regexp t)
				  (or (not *regexp-auto-match-limit*)
					  (< matches *regexp-auto-match-limit* )))
		(forward-char)
		(if (= 0 (length (match-string 0)))
			(plain-error "~A" "Empty regular expression!"))
		(let ((i 0))
		  (incf matches)
		  (while (<= i subexps)
			(when (and (or (not subexp) (= subexp i))
					   (match-beginning i))
			  (unless firstmatch
				(setq firstmatch (match-data)))
			  (incf submatches)
			  (apply #'set-text-attribute
					 (append (list (match-beginning i) (match-end i)
								   *regexp-color-tag*)
							 (nth i *regexp-match-attributes*))))
			(incf i)))))
	(let ((count (if subexp submatches matches)))
	  (message "~A ~Amatch~A~A"
			   (if (= 0 count) "No" (format nil "~D" count))
			   (if subexp "subexpression " "")
			   (if (= 1 count) "" "es")
			   (if (and *regexp-auto-match-limit*
						(= *regexp-auto-match-limit* count))
				   " (limit reached)" "")))
	))

(defun regexp-color-count-subexps (re)
  "Return number of sub-expressions in the regexp RE."
  (let ((i 0) (beg 0))
    (while (string-match "\\\\(" re beg)
      (setq i (1+ i)
            beg (match-end 0)))
    i))

まだあんまり試していないのでバグがあるかも。実際に使うにはこんな風に適当に書いてみるとか、何かそんな感じ。

(defun isearch-regexp-color()
  (interactive)
  (let ((regrexp ed::*isearch-current-string*)
		)
	(when regrexp
	  (pickup-regexp regrexp)
	  (message "isearch-regrexp-color done")
	  )
	))

(define-key *isearch-map* #\M-C 'isearch-regexp-color)

自分で使うように流用して引数とか自由が利くライブラリみたいなのを作った方が速いんじゃないかと何となく思ってみたりした。

■追記
一部修正