日本語混じりの文章で hippie-expand を使う

Emacs にはデフォルトで M-/ に dabbrev-expand が割り当てられていますが、 hippie-expand の方がファイルのパスや Elisp のシンボルも補完してくれる等、機能が豊富です。

hippie-expand の問題点

日本語Nihongo日本語。にほんごNiho-!-

上の例文でカーソル位置は -!- にあります。 M-x hippie-expand としても Nihongo とは補完されません。
理由として2点あります。

(1) Nihongo という単語の両端にスペースがない。
(2) Niho という単語の頭にスペースがない。

半角文字は常にスペースで囲う癖をつければいいのですが、やや面倒です。

(1) の問題を解決するには関数 he-dabbrev-search の再定義をします。

(2) の問題を解決する方法はここの he-dabbrev-beg の定義で示されています。
http://ko.meadowy.net/~shirai/diary/?date=20060125

(1) と (2) の問題を解決したものが以下で、
半角英数、全角英数、漢字、ひらがな、カタカナ、等、同一カテゴリの文字のみを補完するようになります。

(defun my-char-category-regexp (char)
  (let ((c (char-category-set char)))
    (cond
     ((aref c ?a) "\\ca")               ; ASCII
     ((aref c ?j)                       ; Japanese
      (cond
       ((aref c ?K) "\\cK")             ; katakana
       ((aref c ?H) "\\cH")             ; hiragana
       ((aref c ?k) "\\ck")             ; hankaku-kana
       ((aref c ?C) "\\cC")             ; kanji
       ((aref c ?A) "\\cA")             ; 2byte alphanumeric
       ((aref c ?r) "\\cr")             ; Japanese roman ?
       (t "\\cj")))
     ((aref c ?l) "\\cl")               ; Latin
     (t "."))))

;; このコードから借用
;; http://ko.meadowy.net/~shirai/diary/?date=20060125
;; syntax と hippie-expand-dabbrev-as-symbol を使うよう変更。
(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 ((category-regexp (my-char-category-regexp (char-before)))
          (syntax-regexp (if hippie-expand-dabbrev-as-symbol
                             "\\sw\\|\\s_" "\\sw")))
      (save-excursion
        (when (> (point) (minibuffer-prompt-end))
          (forward-char -1)
          (while (and (looking-at syntax-regexp)
                      (looking-at category-regexp)
                      (> (point) (minibuffer-prompt-end))
                      (not (= (point) (field-beginning (point) nil
                                                       (1- (point))))))
            (forward-char -1))
          (or (and (looking-at category-regexp)
                   (looking-at syntax-regexp))
              (forward-char 1)))
        (setq ad-return-value (point))))))

;; syntax と category 両方合致するものを検索する
(defun my-he-dabbrev-search-1 (pattern regpat reverse limit)
  (let ((category-regexp (concat (my-char-category-regexp (aref pattern 0))
                                 "+")))
    (when (if reverse
              (re-search-backward regpat limit t)
            (re-search-forward regpat limit t))
      (if reverse
          (save-excursion
            (goto-char (match-beginning 0))
            (re-search-forward category-regexp (match-end 0) t))
        (goto-char (match-beginning 0))
        (re-search-forward category-regexp (match-end 0) t)))))

;; he-dabbrev-search の再定義。変更個所は [1] [2] [3]
;; 以下の3つの関数から呼ばれる
;; try-expand-dabbrev-visible
;; try-expand-dabbrev
;; try-expand-dabbrev-all-buffers
(defun my-he-dabbrev-search (pattern &optional reverse limit)
  (let ((result ())
        (regpat (cond ((not hippie-expand-dabbrev-as-symbol)
                       (concat "\\<" (regexp-quote pattern) "\\sw+"))
                      ((eq (char-syntax (aref pattern 0)) ?_)
                       (concat (regexp-quote pattern) "\\(\\sw\\|\\s_\\)+"))
                      (t
                       (concat "\\<" (regexp-quote pattern)
                               "\\(\\sw\\|\\s_\\)+")))))
    (while (and (not result)
                ;; [1]
                (my-he-dabbrev-search-1 pattern regpat reverse limit))
      (setq result (buffer-substring-no-properties (match-beginning 0)
                                                   (match-end 0)))
      (if (or (and hippie-expand-dabbrev-as-symbol
                   (> (match-beginning 0) (point-min))
                   (memq (char-syntax (char-after (1- (match-beginning 0))))
                         '(?_ ?w))
                   ;; [2]
                   (eq (char-charset (char-after (1- (match-beginning 0))))
                       'ascii))
              ;; [3]
              (<= (length result) (length pattern))
              (he-string-member result he-tried-table t))
          (setq result nil))) ; ignore if bad prefix or already in table
    result))
(fset 'he-dabbrev-search 'my-he-dabbrev-search)

動作確認：GNU Emacs 22

2011-03-28 追記
関数 my-he-dabbrev-search-1 の引数 reverse が non-nil の時うまく動作していなかったのを修正。