猫熊は燃えつきた？！日記

○ ac-mode じゃなくて hippie-expand 採用

ac-mode を改造したばかりだが、ちょっと限界を感じて hippie-expand の拡張に方向転換してみた。もともと、hippie-expand はファイル名の補完で愛用していたのだ。

• migemo-dabbrev-expand の日本語専用簡易版の try-expand-migemo
• urls.txt または w3m の history arrived-db で補完する try-complete-url
• URL 補完専用のでっちあげ コマンド hippie-expand-url
• ついでに、土屋くんの 光る dabbrev のところに書いてある追加設定の hippie-dabbrev版

といったところ

  (defadvice he-dabbrev-beg
    (around modify-regexp-for-japanese activate compile)
    "Dynamically for Japanese words."
    (if (bobp)
	ad-do-it
      (when hippie-expand-dabbrev-skip-space
	(skip-syntax-backward ". "))
      (let ((char-regexp
	     (let ((c (char-category-set (char-before))))
	       (cond
		((aref c ?a) "[-_A-Za-z0-9]")	; ASCII
		((aref c ?j)			; Japanese
		 (cond
		  ((aref c ?K) "\\cK")	; katakana
		  ((aref c ?A) "\\cA")	; 2byte alphanumeric
		  ((aref c ?H) "\\cH")	; hiragana
		  ((aref c ?C) "\\cC")	; kanji
		  (t "\\cj")))
		((aref c ?k) "\\ck")	; hankaku-kana
		((aref c ?r) "\\cr")	; Japanese roman ?
		(t "[-a-zA-Z0-9_]")))))
	(save-excursion
	  (when (> (point) (minibuffer-prompt-end))
	    (forward-char -1)
	    (while (and (looking-at char-regexp)
			(> (point) (minibuffer-prompt-end))
			(not (= (point) (field-beginning (point) nil
							 (1- (point))))))
	      (forward-char -1))
	    (or (looking-at char-regexp)
		(forward-char 1)))
	  (setq ad-return-value (point))))))
  
  (define-key esc-map "]" 'hippie-expand-url)
  
  (defun hippie-expand-url ()
    "Hipppie の URL 専用補完コマンド"
    (interactive)
    (let ((hippie-expand-try-functions-list '(try-complete-url)))
      (hippie-expand nil)))
  
  (defcustom try-complete-url-file "~/urls.txt"
    "*File name of URLs."
    :type '(choice (file :tag "URLs file")
		   (const :tag "No use" nil))
    :group 'hippie-expand)
  
  (setq hippie-expand-try-functions-list
	'(try-complete-file-name-partially
	  try-complete-file-name
	  try-expand-all-abbrevs
	  try-expand-list
	  try-expand-line
	  try-expand-dabbrev
	  ;; このあたりが良いような気がするが好みの順番で挿入
	  try-expand-migemo ;; これと
	  try-complete-url  ;; これ
	  try-expand-dabbrev-all-buffers
	  try-expand-dabbrev-from-kill
	  try-complete-lisp-symbol-partially
	  try-complete-lisp-symbol))
  
  (defvar try-complete-url-buffer " *url complete*")
  
  (defun he-url-beg ()
    (or (featurep 'ffap) (require 'ffap))
    (save-excursion
      (when hippie-expand-dabbrev-skip-space
	(skip-syntax-backward ". "))
      (ffap-string-at-point 'url)
      (car ffap-string-at-point-region)))
  
  (defun try-complete-url (old)
    "Try to complete word as URL from file and `w3m-input-url-history'.
The argument OLD has to be nil the first call of this function, and t
for subsequent calls (for further possible completions of the same
string).  It returns t if a new completion is found, nil otherwise."
    (unless old
      (he-init-string (he-url-beg) (point))
      (if (not (he-string-member he-search-string he-tried-table))
	  (setq he-tried-table (cons he-search-string he-tried-table)))
      (setq he-expand-list
	    (and (not (equal he-search-string ""))
		 (try-complete-url-1 he-search-string))))
    (while (and he-expand-list
		(he-string-member (car he-expand-list) he-tried-table))
      (setq he-expand-list (cdr he-expand-list)))
    (if (null he-expand-list)
	(progn
	  (if old (he-reset-string))
	  ())
      (progn
	(he-substitute-string (car he-expand-list))
	(setq he-expand-list (cdr he-expand-list))
	t)))
  
  (defun try-complete-url-1 (url)
    (save-excursion
      (let (buf comp w3m w3mbook w3mcomp)
	(when (and try-complete-url-file
		   (file-readable-p try-complete-url-file)
		   (or (executable-find "look")
		       (executable-find "look.exe")))
	  (setq buf (get-buffer-create try-complete-url-buffer))
	  (set-buffer buf)
	  (erase-buffer)
	  (call-process "look" nil buf nil url
			(expand-file-name try-complete-url-file))
	  (sort-lines nil (point-min) (point-max))
	  (setq comp (split-string (buffer-string))))
	(condition-case nil
	    (and (or (featurep 'w3m-bookmark) (require 'w3m-bookmark))
		 (not w3m-arrived-db)
		 (w3m-arrived-setup))
	  (error nil))
	(when (fboundp 'w3m-bookmark-iterator)
	  (setq w3mbook (let ((items (w3m-bookmark-iterator))
			      urls)
			  (while items
			    (setq urls (nconc urls (car items)))
			    (setq items (cdr items)))
			  (all-completions url urls))))
	(when (and (boundp 'w3m-arrived-db)
		   w3m-arrived-db)
	  (setq w3mcomp (all-completions url w3m-arrived-db)))
	(nconc comp w3mbook (sort w3mcomp 'string<)))))
  
  (defun he-migemo-search (pattern &optional reverse limit)
    (let (result beg end)
      (while (and (not result)
		  (if reverse
		      (migemo-backward pattern limit t)
		    (migemo-forward pattern limit t)))
	(setq beg (match-beginning 0))
	(goto-char (match-end 0))
	(unless (re-search-forward ".\\>" (line-end-position) t)
	  (end-of-line))
	(setq end (point))
	(if reverse
	    (goto-char beg)
	  (goto-char end))
	(setq result (buffer-substring-no-properties beg end))
	(when (string-match "\\Cj+$" result)
	  (setq result (substring result 0 (match-beginning 0))))
	(when (or (he-string-member result he-tried-table t)
		  (not (string-match "\\cj" result)))
	  (setq result nil))) ; ignore if bad prefix or already in table
      result))
  
  (defun try-expand-migemo (old)
    "Try to complete word with MIGEMO.
The argument OLD has to be nil the first call of this function, and t
for subsequent calls (for further possible expansions of the same
string).  It returns t if a new expansion is found, nil otherwise."
    (when (fboundp 'migemo-get-pattern)
      (let (expansion)
	(unless old
	  (setq migemo-search-pattern-alist nil)
	  (he-init-string (he-dabbrev-beg) (point))
	  (set-marker he-search-loc he-string-beg)
	  (setq he-search-bw t))
	(unless (equal he-search-string "")
	  (save-excursion
	    (save-restriction
	      (when hippie-expand-no-restriction
		(widen))
	      ;; Try looking backward unless inhibited.
	      (when he-search-bw
		(goto-char he-search-loc)
		(setq expansion
		      (he-migemo-search he-search-string t))
		(set-marker he-search-loc (point))
		(if (not expansion)
		    (progn
		      (set-marker he-search-loc he-string-end)
		      (setq he-search-bw nil))))
	      (unless expansion		; Then look forward.
		(goto-char he-search-loc)
		(setq expansion (he-migemo-search he-search-string nil))
		(set-marker he-search-loc (point))))))
	(if (not expansion)
	    (progn
	      (if old (he-reset-string))
	      ())
	  (progn
	    (he-substitute-string expansion t)
	    t)))))

2006年01月26日(木) 追記: try-complete-url-1() で w3m の bookmark も補完対象にしてみた。

○ いろんな complete その二

現在使っている complete 関係の関数と key bind は

• M-C-i => 普通？の complete
• M-/ => 光る dabbrev-expand
• M-C-/ => hippie-expand (高機能だし。こっちも bind していたりした)
• M-] => (でっちあげ) hippie-expand-url
• M-' => migemo-dabbrev-expand (光る)

とあいなりました。普通の dabbrev-expand は使わないで hippie-expand だけにしても良いけど光らないからね。光るようにしちゃっても良いのだけど。^^;;;

○ 光る hippie-expand

元祖 光る dabbrev 作成者としては、やっぱり光らせたいので、try-expand-dabbrev, try-expand-dabbrev-all-buffers, try-expand-migemo を光るようにしてみた。土屋くんの 光る dabbrevがないとだめ、というかほとんど一緒 :-)

  (defvar he-dabbrev-highlight-function "")
  
  (let (current-load-list)
    (defadvice try-expand-dabbrev
      (after dabbrev-expand-highlight activate)
      "Advised by he-dabbrev-highlight.
Highlight last expanded string."
      (setq he-dabbrev-highlight-function "dabbrev")
      (he-dabbrev-highlight))
    
    (defadvice try-expand-dabbrev-all-buffers
      (after dabbrev-expand-highlight activate)
      "Advised by he-dabbrev-highlight.
Highlight last expanded string."
      (setq he-dabbrev-highlight-function "dabbrev-all-buffers")
      (he-dabbrev-highlight))
    
    (defadvice try-expand-migemo
      (after dabbrev-expand-highlight activate)
      "Advised by he-dabbrev-highlight.
Highlight last expanded string."
      (setq he-dabbrev-highlight-function "migemo")
      (he-dabbrev-highlight)))
  
  (defun he-dabbrev-highlight ()
    (when ad-return-value
      (let ((start (marker-position he-search-loc))
	    (len (length (car he-tried-table)))
	    (buf (marker-buffer he-search-loc))
	    (cbuf (current-buffer))
	    end wait)
	(save-selected-window
	  (save-excursion
	    (if (eq buf cbuf)
		(if (> start (point))
		    (setq end start
			  start (- end len))
		  (setq end (+ start len)))
	      (set-buffer buf)
	      (setq end start
		    start (- end len)))
	    (if (and (get-buffer-window buf)
		     (select-window (get-buffer-window buf))
		     (pos-visible-in-window-p start)
		     (pos-visible-in-window-p end))
		(progn
		  ;; Highlight the string used for the last expansion.
		  (if dabbrev-highlight-overlay
		      (move-overlay dabbrev-highlight-overlay start end)
		    (setq dabbrev-highlight-overlay (make-overlay start end)))
		  (overlay-put dabbrev-highlight-overlay
			       'face dabbrev-highlight-face)
		  (add-hook 'pre-command-hook 'dabbrev-highlight-done))
	      (unless (minibufferp cbuf)
		;; Display one-line summary in minibuffer.
		(save-excursion
		  (save-restriction
		    (widen)
		    (goto-char start)
		    (let ((str (buffer-substring-no-properties start end))
			  (bol (progn (forward-line 0) (point)))
			  (eol (progn (end-of-line) (point))))
		      (if (or (featurep 'xemacs)
			      (<= emacs-major-version 20))
			  (setq str (concat " *" str "* "))
			(put-text-property 0 (length str)
					   'face dabbrev-highlight-face str)
			(put-text-property 0 (length he-dabbrev-highlight-function)
					   'face 'bold he-dabbrev-highlight-function))
		      (message "%s: %s(%d): %s%s%s"
			       (format "Using %s" he-dabbrev-highlight-function)
			       (buffer-name buf)
			       (count-lines (point-min) start)
			       (buffer-substring-no-properties bol start)
			       str
			       (buffer-substring-no-properties end eol))
		      (setq wait t))))))))
	(when wait
	  (let ((inhibit-quit t))
	    (sit-for 10)
	    (when quit-flag
	      (setq quit-flag nil)
	      (setq unread-command-events '(7))))))))

sit-for() で逃げてよわーいけど、C-g 対応した。めんどくさいので、XEmacs ではうごきません。

○ そうです

仕事(書類書き ;_;)に疲れてしまって、げんじつとーひをしてしまったのです。