kogiku/kogiku/kogiku.el

;;; kogiku.el - reading file and directory names with migemo service

;; Copyright (C) 2004 Masatake YAMATO

;; Author: Masatake YAMATO <jet@gyve.org>

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;; 譌･譛ｬ隱槭ヵ繧｡繧､繝ｫ蜷阪?蜈･蜉帙ｒmigemo繧剃ｽｿ縺｣縺ｦ邁｡蜊倥↓縺吶ｋ繝励Ο繧ｰ繝ｩ繝?縺ｧ縺吶??/span>

;; (莉翫?菴ｿ縺｣縺ｦ縺?↑縺??縺ｧ縺吶′縲?莉･蜑購indows縺ｧmeadow繧剃ｽｿ縺｣縺ｦ縺?◆縺ｨ縺阪↓縲?/span>
;; 縲後ョ繧ｹ繧ｯ繝医ャ繝?螳滄圀縺ｫ縺ｯ蜊願ｧ?縲阪↓縺ｶ縺｡縺ｾ縺代※縺ゅｋ繝輔ぃ繧､繝ｫ繧断ind-file縺?/span>
;; 繧医≧縺ｨ縺吶ｋ縺ｨ(莉ｮ蜷肴ｼ｢蟄怜､画鋤縺悟ｿ?ｦ√↑縺溘ａ)繝輔ぃ繧､繝ｫ蜷阪?謖?ｮ壹′髱槫ｸｸ縺ｫ髱｢蛟偵〒
;; 縺ゅｋ縺ｨ諢溘§縺ｾ縺励◆縲?quot;desukutoxtupu"縺ｨ謇馴嵯縺励※縺昴ｌ繧偵?後ョ繧ｹ繧ｯ繝医ャ繝励?阪∈螟画鋤
;; 縺励※[return]縺ｧ繧?▲縺ｨ謖?ｮ壹☆繧九％縺ｨ縺後〒縺阪∪縺励◆縲?/span>

;; 縲後ョ繧ｹ繧ｯ繝医ャ繝励?阪?謖?ｮ壹ｒ縺溘→縺医?縲?quot;desktop"縺ｨ縺 "de"[tab]縺ｨ縺九〒貂医ａ縺ｰ
;; 縺吶?繧峨＠縺?→諤昴＞縺ｾ縺帙ｓ縺具ｼ殞igemo繧剃ｽｿ縺医?縺薙ｌ繧貞ｮ溽樟縺吶ｋ縺薙→縺後〒縺阪◎縺?/span>
;; 縺ｧ縺吶??quot;desktop"繧?quot;de"繧知igemo縺ｧ譌･譛ｬ隱槭↓螻暮幕縺励?∝ｱ暮幕貂医∩縺ｮ繝代ち繝ｼ繝ｳ繧?/span>
;; 迴ｾ蝨ｨ縺ｮ繝?ぅ繝ｬ繧ｯ繝医Μ縺ｫ縺ゅｋ蜈ｨ縺ｦ縺ｮ繝輔ぃ繧､繝ｫ縺ｮ蜷榊燕縺ｨ辣ｧ蜷医☆繧後?縲√ヵ繧｡繧､繝ｫ蜷?/span>
;; 繧呈欠螳?"desktop"縺ｨ縲後ョ繧ｹ繧ｯ繝医ャ繝励?阪?荳?閾ｴ)縺励◆繧翫?∬｣懷ｮ悟?呵｣懊ｒ逕滓?
;; ("de"縺ｨ縲後ョ繧ｹ繧ｯ繝医ャ繝励?阪?荳?閾ｴ)縺励◆繧翫☆繧九％縺ｨ縺後〒縺阪∪縺吶??/span>

;; kogiku.el縺ｯmigemo.el蜿翫?GNU Emacs 21縺ｫ萓晏ｭ倥＠縺ｦ縺?∪縺吶?Ｎigemo.el縺ｮ
;; 蜍穂ｽ懊ｒ縺ｾ縺夂｢ｺ隱阪＠縺ｦ荳九＆縺??Ｌogiku.el繧偵Ο繝ｼ繝峨ヱ繧ｹ縺碁?壹▲縺ｦ騾壹▲縺ｦ縺?ｋ
;; 繝?ぅ繝ｬ繧ｯ繝医Μ縺ｫ鄂ｮ縺?emacs縺ｫ (require 'kogiku)縺ｨ譖ｸ縺榊刈縺医※emacs繧貞?
;; 襍ｷ蜍輔＠縺ｾ縺吶?Ｎigemo縺ｯ http://migemo.namazu.rog 縺九ｉ蜈･謇九〒縺阪∪縺吶??/span>

;;; Acknowledgments:

;; Some code used in `kogiku-file-name-completion'
;; and `kogiku-try-completion-regexp' are copied from
;; http://www.bookshelf.jp/cgi-bin/goto.cgi?file=meadow&node=kogiku
;; (MeadowMemo maintained by Akihisa Matsushita <akihisa@mail.ne.jp>).

;; `kogiku-read-file-name-internal' are
;; translated from emacs/src/fileio.c::read-file-name-internal
;; in elisp.

;;; Version:
;; 2.0.2.

;;; History:
;; 2.0.2
;; -- inlucde shirai's patch
;; -- introduce custom
;;
;; 2.0.1 -- update `Acknowledgments'.
;;
;; 2.0 -- rewrite.

;;; Code:

(eval-when-compile
  (require 'cl)
  (require 'migemo))

(defgroup kogiku nil
  "reading file and directory name with migemo service"
  :group 'convenience)

(defcustom kogiku-minibuffer-prompt-string "kogiku"
  "*Kogiku indicator in minibuffer."
  :group 'kogiku
  :type 'string)

(defcustom kogiku-enable-once nil
  "*If non-nil, kogiku effects a one time when call with a prefix argument.
If nil, kogiku toggle with a prefix argument."
  :group 'kogiku
  :type 'boolean)

(defcustom kogiku-mode-change-key "\M-k"
  "*Key of change `kogiku-enable-once'."
  :group 'kogiku
  :type 'sexp)

(defface kogiku-indicator-face
  '((((class color) (type tty)) (:foreground "blue" :bold t))
    (((class color) (background light)) (:foreground "dark blue" :bold t))
    (((class color) (background dark))  (:foreground "cyan" :bold t))
    (t (:bold t)))
  "*Face of kogiku indicator."
  :group 'kogiku)

(defface kogiku-change-face
  '((((class color) (type tty)) (:foreground "blue"))
    (((class color) (background light)) (:foreground "dark blue"))
    (((class color) (background dark))  (:foreground "cyan"))
    (t (:underline t)))
  "*Face of kogiku indicator."
  :group 'kogiku)

(defcustom kogiku-take-over-targets '(read-file-name-internal
                                      ffap-read-file-or-url-internal)
  "蟆剰所縺後?縺｣縺ｨ繧?/span>`minibuffer-completion-table'縺ｮ遞ｮ鬘槭??/span>
minibuffer縺ｫ蛻ｶ蠕｡縺檎ｧｻ縺｣縺溘→縺阪↓`minibuffer-completion-table'縺ｮ蛟､縺?/span>
`kogiku-take-over-targets'縺ｮ隕∫ｴ?縺ｧ縺ゅｌ縺ｰ縲∝ｰ剰所縺ｫ繧医ｋ陬懷ｮ後?貅門ｙ繧定｡後↑縺???quot;
  :group 'kogiku
  :type '(repeat symbol))

(defvar kogiku-original-functions nil)
(defvar kogiku-original-completion-table nil)

(defvar kogiku-completion-key "\t")
(defvar kogiku-minibuffer-prompt-overlay nil)
(defvar kogiku-mode-change-original-functions nil)

(defun kogiku-complete (&optional arg)
  (interactive "P")
  (if kogiku-enable-once
      (kogiku-oneshot-complete arg)
    (kogiku-complete-with-toggle arg)))

(defun kogiku-oneshot-complete (fire)
  (let ((minibuffer-completion-table minibuffer-completion-table))
    (when fire
      (setq minibuffer-completion-table 'kogiku-read-file-name-internal))
    (funcall (car kogiku-original-functions))))

(defun kogiku-complete-with-toggle (switch)
  (cond
   ((and switch
         (eq minibuffer-completion-table 'kogiku-read-file-name-internal))
    (setq minibuffer-completion-table kogiku-original-completion-table))
   (switch
    (setq minibuffer-completion-table 'kogiku-read-file-name-internal)))
  (funcall (car kogiku-original-functions))
  (kogiku-minibuffer-prompt))

(defun kogiku-minibuffer-prompt ()
  (if (fboundp 'field-beginning)
      ;; Emacs 21
      (let ((prompt (buffer-substring (point-min) (field-beginning)))
            (props (text-properties-at (point-min)))
            (indicator (format " [%s]" kogiku-minibuffer-prompt-string))
            (buffer-read-only nil)
            (inhibit-read-only t)
            replace)
        (save-excursion
          (when (string-match (regexp-quote indicator) prompt)
            (setq replace t)
            (setq prompt (replace-match "" nil nil prompt))
            (set-text-properties 0 (length prompt) props prompt))
          (when (and (eq minibuffer-completion-table
                         'kogiku-read-file-name-internal)
                     (string-match ":[^:]*" prompt))
            (setq replace t)
            (set-text-properties 0 (length indicator) props indicator)
            (add-text-properties 0 (length indicator)
                                 '(face kogiku-indicator-face) indicator)
            (setq prompt (concat (substring prompt 0 (match-beginning 0))
                                 indicator
                                 (substring prompt (match-beginning 0)))))
          (when replace
            (delete-region (point-min) (field-beginning))
            (goto-char (point-min))
            (insert prompt))))
    ;; Others
    (if (eq minibuffer-completion-table 'kogiku-read-file-name-internal)
        (let ((max (min (point-max) (1+ (point-min)))))
          (if kogiku-minibuffer-prompt-overlay
              (move-overlay kogiku-minibuffer-prompt-overlay
                            (point-min) max)
            (setq kogiku-minibuffer-prompt-overlay
                  (make-overlay (point-min) max)))
          (overlay-put kogiku-minibuffer-prompt-overlay
                       'before-string
                       (format "%s: " kogiku-minibuffer-prompt-string))
          (overlay-put kogiku-minibuffer-prompt-overlay 'evaporate t))
      (when kogiku-minibuffer-prompt-overlay
        (delete-overlay kogiku-minibuffer-prompt-overlay)))))

(if (fboundp 'compare-strings)
    (defalias 'kogiku-compare-strings 'compare-strings)
  (defun kogiku-compare-strings (string1 start1 end1 string2 start2 end2)
    "Convenience `compare-strings' for XEmacs."
    (let* ((str1 (substring string1 start1 end1))
           (str2 (substring string2 start2 end2))
           (len (min (length str1) (length str2)))
           (i 0))
      (if (string= str1 str2)
          t
        (setq i (catch 'ignore
                  (while (< i len)
                    (when (not (eq (aref str1 i) (aref str2 i)))
                      (throw 'ignore i))
                    (setq i (1+ i)))
                  i))
        (1+ i)))))

(defun kogiku-try-completion-regexp (regexp all-list)
  (if (= (length regexp) 0)
      ""
    (let (common)
      (setq common
            (substring
             (car all-list)
             0
             (apply 'min
                    (mapcar
                     (lambda (a)
                       (apply 'min
                              (mapcar
                               (lambda (b)
                                 (- (abs
                                     (kogiku-compare-strings a 0 nil
                                                      b 0 nil))
                                    1))
                               (delete a all-list))))
                     all-list))))
      common)))

(defun kogiku-migemo-get-pattern (string)
  (let ((migemo-pattern-alist migemo-pattern-alist)
        (migemo-white-space-regexp " *"))
    (let ((case-fold-search nil))
      (while (string-match "[^a-zA-Z]\\([a-z]+\\)" string)
        (setq string
              (replace-match (capitalize (match-string 1 string)) nil nil string 1))))
    (migemo-get-pattern string)))

(defun kogiku-file-name-completion (string dir &optional all)
  (let* ((expanded-string (expand-file-name string dir))
         (files (directory-files dir))
         (pattern
          (if (string-match "/$" expanded-string)
              ""
            (concat "^\\("
                    (cond
                     ((string-match "\\cj$" string)
                      string)
                     ((string-match "^\\(\\(\\Cj*\\)?\\cj+\\)\\(\\Cj+\\)$" string)
                      (concat (match-string 1 string)
                              "\\("
                              (kogiku-migemo-get-pattern (match-string 3 string))
                              "\\)"))
                     (t
                      (kogiku-migemo-get-pattern (file-name-nondirectory string))))
                    "\\)")))
         (candidates (delete nil
                            (mapcar
                             (lambda (f)
                               (if (string-match pattern f)
                                   (if (file-directory-p (expand-file-name f dir))
                                       ;; 繝?ぅ繝ｬ繧ｯ繝医Μ縺ｯ / 縺ｧ邨ゅｏ繧九ｈ縺?↓
                                       (file-name-as-directory f)
                                     f)))
                             files)))
         (count (length candidates))
         common)
    (if all
        candidates
      (cond
       ((eq count 0) nil)
       ((eq count 1) (let ((candidate (car candidates)))
                       (if (file-directory-p candidate)
                           (file-name-as-directory candidate)
                         candidate)))
       (t
        (if (null (delete nil (mapcar (lambda (candidate)
                                        (string-match "\\cj" candidate))
                                      candidates)))
            ;; 蜈ｨ縺ｦ縺ｮ蛟呵｣懊′譌･譛ｬ隱槭ｒ蜷ｫ繧薙〒縺?↑縺??ｴ蜷医???壼ｸｸ騾壹ｊ
            ;; `try-completion' 繧貞他繧薙〒縺ｾ縺九○繧九??/span>
            (try-completion string (mapcar 'list candidates))
          (setq common (kogiku-try-completion-regexp pattern candidates))
          (if (eq (length common) 0) string common)))))))

(defun kogiku-file-name-all-completions (string dir)
  (kogiku-file-name-completion string dir t))

(defun kogiku-double-dollars (input)
  (let ((ret ""))
    (while (string-match "\\$" input)
      (setq ret (concat ret
                        (substring input 0 (match-beginning 0))
                        "$$"))
      (setq input (substring input (match-end 0))))
    (concat ret input)))

(defun kogiku-read-file-name-internal (string dir action)
  (block nil
    (unless (boundp 'read-file-name-predicate)
      (setq read-file-name-predicate nil))
    (let ((realdir dir)
          (name string)
          (orig-string)
          (changed 0)
          (val)
          (specdir))
      (if (eq 0 (length string))
          (if (eq action 'lambda)
              (return nil))
        (setq orig-string string)
        (setq string (substitute-in-file-name string))
        (setq changed (null (string-equal string orig-string)))
        (setq name (file-name-nondirectory string))
        (setq val  (file-name-directory string))
        (if (not (null val))
            (setq realdir (expand-file-name val realdir))))
      (cond
       ((null action)
        (setq specdir (file-name-directory string))
        (setq val     (kogiku-file-name-completion name realdir))
        (return (if (not (stringp val))
                    (if changed
                        (kogiku-double-dollars string)
                      val)
                  (if (not (null specdir))
                      (setq val (concat specdir val)))
                  (kogiku-double-dollars val))))
       ((eq action t)
        (let ((all (kogiku-file-name-all-completions name realdir)))
          (unless (or (null read-file-name-predicate)
                      (eq read-file-name-predicate 'file-exists-p))
            (delete-if (lambda (x)
                         (not (funcall read-file-name-predicate x))
                         all)))
          (return all)))
       ((eq action 'lambda)
        (return (if read-file-name-predicate
                    (funcall read-file-name-predicate string)
                  (file-exists-p string))))))))

(defun kogiku-mode-change ()
  (interactive)
  (setq kogiku-enable-once (not kogiku-enable-once))
  (when (and kogiku-enable-once
             (eq minibuffer-completion-table 'kogiku-read-file-name-internal))
    (setq minibuffer-completion-table 'read-file-name-internal))
  (when (and (not kogiku-enable-once)
             (eq minibuffer-completion-table 'read-file-name-internal))
    (setq minibuffer-completion-table 'kogiku-read-file-name-internal))
  (kogiku-minibuffer-prompt)
  (let ((msg (format "[%s%s-mode]"
                     (if kogiku-enable-once
                         (concat kogiku-minibuffer-prompt-string " ") "")
                     (if kogiku-enable-once "ONESHOT" "TOGGLE")))
        (max (point-max))
        (inhibit-quit t))
    (put-text-property 0 (length msg) 'face 'kogiku-change-face msg)
    (save-excursion
      (goto-char max)
      (insert "  " msg))
    (sit-for 5)
    (save-excursion
      (delete-region max (point-max)))))

(defun kogiku-install-key ()
  (when (memq minibuffer-completion-table kogiku-take-over-targets)
    (setq kogiku-original-completion-table minibuffer-completion-table)
    (push (lookup-key (current-local-map) kogiku-completion-key)
          kogiku-original-functions)
    (define-key (current-local-map) kogiku-completion-key 'kogiku-complete)
    (push (lookup-key (current-local-map) kogiku-mode-change-key)
          kogiku-mode-change-original-functions)
    (define-key (current-local-map) kogiku-mode-change-key 'kogiku-mode-change)))

(add-hook 'minibuffer-setup-hook 'kogiku-install-key)

(defun kogiku-uninstall-key ()
  (when (and (or (eq minibuffer-completion-table 'kogiku-read-file-name-internal)
                 (memq minibuffer-completion-table kogiku-take-over-targets))
             (eq (lookup-key (current-local-map) kogiku-completion-key)
                 'kogiku-complete))
    (define-key (current-local-map) kogiku-completion-key (pop kogiku-original-functions))
    (when (eq (lookup-key (current-local-map) kogiku-mode-change-key)
              'kogiku-mode-change)
      (define-key (current-local-map) kogiku-mode-change-key
        (pop kogiku-mode-change-original-functions)))))

(add-hook 'minibuffer-exit-hook 'kogiku-uninstall-key)

(provide 'kogiku)
;; kogiku.el ends here