;;; abbrev-complete.el
;;;$Id: abbrev-complete.el,v 2.8 2007/11/04 13:37:16 akihisa Exp $

;; Author: Matsushita Akihisa <akihisa@mail.ne.jp>
;; Keywords: abbrev expand completion convenience

;; This program 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 3, or (at
;; your option) any later version.

;; This program 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; abbrev mode completion function

;; If you type M-x expand-abbrev in line head, abbreviations are listed to other window.

;; And you can operate like following expression. 

;; a M-x expand-abbrev
;; your addres M-x expand-abbrev (your addres = expansion of addres)
;; as far as I can tell M-x expand-abbrev (expansion of afaict)
;; abbrev  M-x expand-abbrev (expansion by dabbrev)
;; after  M-x expand-abbrev (expansion by dabbrev)

;;; Install:

;; Put this file into load-path'ed directory, and byte compile it if
;; desired.  And put the following expression into your ~/.emacs.
;;
;;     (require 'abbrev-complete)

;; The latest version of this program can be downloaded from
;; http://www.bookshelf.jp/elc/abbrev-complete.el

;; Customize

;; If you use with hippie-expand, remove try-expand-all-abbrevs and
;; try-expand-dabbrev, try-expand-dabbrev-all-buffers from
;; hippie-expand-try-functions-list.

;; example

;; (setq abbrev-complete-use-hippie t)
;; (setq hippie-expand-try-functions-list
;;   '(try-complete-file-name-partially
;;     try-complete-file-name
;;     try-expand-list
;;     try-expand-line
;;     try-complete-lisp-symbol-partially
;;     try-complete-lisp-symbol))

;;; History:

;; 2003/06/25: Add abbrev-complete-use-hippie
;; 2002/12/18: Add abbrev-complete-not-abbrev-completion-seg
;;             Add abbrev-complete-immediately-dabbrev-completion-seg
;; 2002/12/12: Bug fix. abbrev-complete-dabbrev-expand ()
;; 2002/12/11: Add abbrev-complete-word-seg.
;;             Add abbrev-complete-completion
;;             Add abbrev-complete-show-completion
;;             Highlight *Completions*.
;; 2002/12/07:Ver.1.00

;; TODO
;; Rewrite :)
;; Document

;;; Code:

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

;; User variables
(defvar abbrev-complete-no-entry-dabbrev t
  "*non-nil means this program completes by dabbrev")

(defvar abbrev-complete-show-completion 'always
  "*nil means don't show *Completions* buffer.
t:Show *Completions* buffer
'always:Show *Completions* buffer even one word
'view:Show *Completions* buffer after abbrev-complete-word-seg")

(defvar abbrev-complete-word-seg "[- \"#%&'()\=~]"
  "*Segmentation of word")

(defvar abbrev-complete-completion t
  "*non-nil means, try completion for abbrev")

(defvar abbrev-complete-not-dabbrev-seg "[\\\\]"
  "*non-nil means, try completion for abbrev")

(defvar abbrev-complete-not-abbrev-completion-seg "[-\"#\%&'()\=~]"
  "*After abbrev-complete-not-abbrev-completion-seg, not complete by abbrev")

(defvar abbrev-complete-immediately-dabbrev-completion-seg "[-]"
  "*If you expand \"a-\", this program complete by dabbrev immediately")

(defvar abbrev-complete-use-hippie nil
  "*non-nil means to use hippie-expand")

(defvar abbrev-complete-add-region-to-abbrev t
  "*non-nil means to add the region text to abbrev")


;; Internal variables
(defvar enable-abbrev-complete t)
(defvar abbrev-complete-word "")
(defvar abbrev-complete-start-position nil)
(defvar abbrev-complete-before-abbrev nil)
(defvar abbrev-complete-before-dabbrev nil)
(defvar abbrev-complete-table nil)
(defvar abbrev-complete-table-prev nil)
(defvar abbrev-complete-maybes nil)
(defvar abbrev-complete-maybes-all nil)
(defvar abbrev-complete-highlight-face 'highlight)
(defvar abbrev-complete-highlight-overlay nil)
(defvar abbrev-complete-do-dabbrev t)
(defvar abbrev-complete-do-abbrev t)
(defvar abbrev-complete-not-dabbrev-seg-internal "")
(defvar abbrev-completion-dabbrev-word "")
(defvar abbrev-completion-point nil)
(defvar abbrev-complete-use-hippie-internal nil)
(defvar abbrev-complete-mode-buffer "*abbrev*")
(defvar abbrev-complete-mode-parent-buffer nil)
(defvar abbrev-complete-mode-map nil)
(defvar abbrev-complete-windows-conf nil)

(or abbrev-complete-mode-map
    (let ((map (make-sparse-keymap)))
      (define-key map "\C-c\C-c"
        (function abbrev-complete-mode-add-abbrev))
      (define-key map "\C-c\C-q"
        (function abbrev-complete-mode-quit))

      (setq abbrev-complete-mode-map map)
      ))


(defadvice expand-abbrev
  (around check-abbrev-list activate)
  (if (not (eq last-command this-command))
      (setq abbrev-complete-windows-conf (current-window-configuration)))
  (cond
   ((not enable-abbrev-complete)
    ad-do-it)
   ((string-match "\^M" (this-command-keys))
    ad-do-it)
   ((and abbrev-complete-add-region-to-abbrev
         mark-active)
    (abbrev-complete-add-abbrev)
    )
   (t
    (condition-case err
        (abbrev-complete)
      (error nil))
    (if abbrev-complete-before-abbrev
        (progn
          ;;(delete-region abbrev-complete-start-position abbrev-completion-point)
          ;;(insert (car abbrev-complete-maybes))
          ;;(insert abbrev-complete-word)
          (let (str tp empty)
            (if (= (point-max) (point))
                (if (= (point-min) (point))
                    (setq empty t)
                  (put-text-property (- (point) 1) (point) 'abbcomp t))
              (put-text-property (point) (+ (point) 1) 'abbcomp t))

            ad-do-it

            ;;(save-excursion (goto-char (point-max)) (insert "  ->normal \n"))
            (save-excursion
              (if empty
                  (setq abbrev-completion-point (point-max))
                (setq tp (get-text-property (point) 'abbcomp))
                (while (not tp)
                  (if (= (point) (point-max))
                      (setq tp t)
                    (forward-char 1)
                    (setq tp (get-text-property (point) 'abbcomp))))
                (setq abbrev-completion-point (point))
                (remove-text-properties (point-min) (point-max) '(abbcomp nil))))))))))

(defun abbrev-complete-add-abbrev ()
  (let ((pbuf (current-buffer))
        (mode major-mode)
        (exp
         (buffer-substring-no-properties
          (region-beginning) (region-end)))
        name table)
    (with-output-to-temp-buffer abbrev-complete-mode-buffer
      (set-buffer abbrev-complete-mode-buffer)
      (kill-all-local-variables)

      (if (functionp mode)
          (condition-case err
              (call-interactively mode)
            (error
             ()))
        (error "Can't be determined major-mode!"))

      (make-local-variable 'abbrev-complete-mode-parent-buffer)
      (setq abbrev-complete-mode-parent-buffer pbuf)

      (use-local-map abbrev-complete-mode-map)
      (princ exp)))
  (pop-to-buffer abbrev-complete-mode-buffer))

(defun abbrev-complete-mode-add-abbrev ()
  (interactive)
  (let ((exp
         (buffer-substring-no-properties
          (point-min)
          (save-excursion
            (goto-char (point-max))
            (while (string-match "[\n ]" (buffer-substring (- (point) 1) (point)))
              (forward-char -1))
            (point))))
        name table)
    (if (or only-global-abbrevs
            (y-or-n-p "Global abbrev? "))
        (setq table global-abbrev-table)
      (if local-abbrev-table
          (setq table local-abbrev-table)
        (error "No per-mode abbrev table")))
    (setq name
          (read-string (format (if exp "abbrev for \"%s\": "
                                 "Undefine %s abbrev: ")
                               exp)))
    (set-text-properties 0 (length name) nil name)
    (if (or (null exp)
            (not (abbrev-expansion name table))
            (y-or-n-p (format "%s expands to \"%s\"; redefine? "
                              name (abbrev-expansion name table))))
        (define-abbrev table (downcase name) exp)))
  (abbrev-complete-mode-quit))

(defun abbrev-complete-mode-quit ()
  (interactive)
  ;;(switch-to-buffer abbrev-complete-mode-parent-buffer)
  (kill-buffer abbrev-complete-mode-buffer)
  (if (window-configuration-p abbrev-complete-windows-conf)
      (set-window-configuration abbrev-complete-windows-conf))
  )

(defun abbrev-comple-delete-window ()
  (if (and (get-buffer "*Completions*")
           (get-buffer-window (get-buffer "*Completions*")))
      (progn
        (setq abbrev-complete-table-prev nil)
        (delete-window (get-buffer-window (get-buffer "*Completions*")))
        (kill-buffer (get-buffer "*Completions*"))
        (if (window-configuration-p abbrev-complete-windows-conf)
            (set-window-configuration abbrev-complete-windows-conf))
        )))

(defun abbrev-complete-dabbrev-expand ()
  (abbrev-comple-delete-window)
  (cond
   ((or (not (= he-num -1)) abbrev-complete-use-hippie-internal)
    (setq abbrev-complete-use-hippie-internal nil)
    (call-interactively 'hippie-expand)
    (when he-expand-list
      (with-output-to-temp-buffer "*Completions*"
        (display-completion-list he-expand-list))))
   (t
    (condition-case err
        (dabbrev-expand nil) ;; No further expansion -> error
      (error
       (delete-region abbrev-complete-start-position (point))
       (insert abbrev-complete-word)
       (if (not (= 0 (length abbrev-complete-not-dabbrev-seg-internal)))
           (insert abbrev-complete-not-dabbrev-seg-internal))
       (dabbrev--reset-global-variables)
       (setq he-num -1)
       (setq abbrev-complete-use-hippie-internal abbrev-complete-use-hippie)
       (setq abbrev-complete-before-abbrev nil)
       (setq abbrev-complete-before-dabbrev nil)
       (setq abbrev-complete-maybes
             (sort
              (append
               (all-completions abbrev-complete-word global-abbrev-table)
               (all-completions abbrev-complete-word local-abbrev-table))
              'string<))
       (setq abbrev-complete-maybes-all abbrev-complete-maybes)
       (setq abbrev-complete-table (abbrev-complete-make-list abbrev-complete-maybes-all))
       (setq abbrev-completion-point (point))
       (message "No further dynamic expansion for `%s' found" abbrev-completion-dabbrev-word)
       )))))

(defun abbrev-complete-expand-abbrev ()
  (setq abbrev-complete-before-abbrev nil)
  (setq abbrev-complete-before-dabbrev t)
  (abbrev-complete-dabbrev-expand)
  (if  (string= "*Completions*"
                (buffer-name (window-buffer (next-window))))
      (abbrev-comple-delete-window)
    ))

(defun abbrev-complete-highlight-completions ()
  (let (cbuf start end)
    (setq cbuf (current-buffer))
    (set-buffer (get-buffer "*Completions*"))
    (goto-char (point-min))
    (if (re-search-forward (concat "\\("
                                   (car abbrev-complete-maybes)
                                   "\\)[ ]+->") nil t)
        (progn
          (setq start (match-beginning 1))
          (setq end (match-end 1))))
    (if abbrev-complete-highlight-overlay
        (move-overlay abbrev-complete-highlight-overlay start end)
      (setq abbrev-complete-highlight-overlay (make-overlay start end)))
    (overlay-put abbrev-complete-highlight-overlay
                 'face abbrev-complete-highlight-face)
    (add-hook 'pre-command-hook
              (lambda ()
                (if abbrev-complete-highlight-overlay
                    (delete-overlay abbrev-complete-highlight-overlay))))
    (set-buffer cbuf)
    ))

(defun abbrev-complete-car-expand ()
  (let (str tp empty (enable-abbrev-complete nil))
    (if (= (point-max) (point))
        (if (= (point-min) (point))
            (setq empty t)
          (put-text-property (- (point) 1) (point) 'abbcomp t))
      (put-text-property (point) (+ (point) 1) 'abbcomp t))
    (insert (car abbrev-complete-maybes))
    
    ;;(ad-deactivate 'expand-abbrev)
    (expand-abbrev)
    ;;(ad-activate 'expand-abbrev)
    
    (save-excursion
      (if empty
          (setq abbrev-completion-point (point-max))
        (setq tp (get-text-property (point) 'abbcomp))
        (while (not tp)
          (if (= (point) (point-max))
              (setq tp t)
            (forward-char 1)
            (setq tp (get-text-property (point) 'abbcomp))))
        (setq abbrev-completion-point (point))
        (remove-text-properties (point-min) (point-max) '(abbcomp nil))))

    (message "Expansion for '%s'" (car abbrev-complete-maybes))
    (if (string= "*Completions*"
                 (buffer-name (window-buffer (next-window))))
        (abbrev-complete-highlight-completions))
    ;;(setq abbrev-complete-table (cdr abbrev-complete-table))
    (setq abbrev-complete-maybes
          (cdr abbrev-complete-maybes))))

(defun abbrev-complete-get-info (name)
  (let ((enable-abbrev-complete nil))
    (let ((str (split-string
                (abbrev-expansion name) "\n")) (w (- (window-width) 15)))
      (setq str (truncate-string
                 (mapconcat (lambda (y) y) str
                            "^J") w))
      str
      )))

(defun abbrev-complete-make-list (completion-list)
  (let ((lst completion-list) (str-list nil) (w (- (window-width) 15))
        abbrev-str)
    (while lst
      (setq abbrev-str
            (format (concat "%-" (int-to-string (/ (window-width) 3)) "s"
                            " -> %s")
                    (car lst)
                    (truncate-string
                     (abbrev-complete-get-info (car lst))
                     (/ (window-width) 3))))
      (setq str-list
            (cons
             (truncate-string
              abbrev-str
              w)
             str-list))
      (setq lst (cdr lst)))
    (reverse str-list)))

(defun abbrev-complete-display-completion ()
  (if (and
       (eq abbrev-complete-table abbrev-complete-table-prev)
       (get-buffer "*Completions*")
       (get-buffer-window (get-buffer "*Completions*")))
      (let* ((other-window-scroll-buffer (get-buffer "*Completions*"))
            (pt (save-current-buffer (set-buffer other-window-scroll-buffer)
                                     (point))))
        (if (not (= 0 (length abbrev-complete-word)))
            (save-current-buffer (set-buffer other-window-scroll-buffer)
                                 (re-search-forward (concat (car abbrev-complete-maybes)) nil t))
          (scroll-other-window)
          (if (= pt (save-current-buffer (set-buffer other-window-scroll-buffer)
                                         (point)))
              (with-output-to-temp-buffer "*Completions*"
                (display-completion-list abbrev-complete-table)
                ))))
    (with-output-to-temp-buffer "*Completions*"
      (display-completion-list abbrev-complete-table)
      )
    )
  (setq abbrev-complete-table-prev abbrev-complete-table)
  )


(defun abbrev-complete ()
  (interactive)
  (when enable-abbrev-complete
    (let* (pos word)
      (if abbrev-complete-use-hippie
          (require 'hippie-exp))
      ;; abbrev-complete-completion : reset
      (if (featurep 'lcomp)
          (setq lcomp-before-completion-winconf nil))
      (setq abbrev-complete-before-abbrev nil)
      (if (and abbrev-complete-completion
               (eq last-command this-command))
          (cond
           ((and (not abbrev-complete-before-dabbrev)
                 (and abbrev-complete-do-dabbrev
                      abbrev-complete-no-entry-dabbrev))
            (progn
              (if (> abbrev-completion-point (point-max))
                  (delete-region abbrev-complete-start-position (point))
                (delete-region abbrev-complete-start-position abbrev-completion-point))
              (insert abbrev-complete-word)
              (setq abbrev-completion-point (point))
              ))))

      (if (eq last-command this-command)
          ()
        (progn
          ;; Reset all variables
          (setq abbrev-complete-use-hippie-internal abbrev-complete-use-hippie)
          (setq he-num -1)
          (dabbrev--reset-global-variables)
          (setq abbrev-complete-do-dabbrev abbrev-complete-no-entry-dabbrev)
          (setq abbrev-complete-before-abbrev nil)
          (setq abbrev-complete-before-dabbrev nil)
          (setq abbrev-complete-not-dabbrev-seg-internal nil)
          (setq abbrev-complete-do-abbrev t)
          (setq abbrev-completion-point (point))
    
          ;; Read and delete suffix
          (cond
           ((string-match
             abbrev-complete-not-dabbrev-seg
             (char-to-string (preceding-char)))
            (progn
              (setq abbrev-complete-not-dabbrev-seg-internal (char-to-string (preceding-char)))
              (delete-region (- (point) 1) (point))
              (setq abbrev-complete-do-dabbrev nil)
              (setq abbrev-completion-point (point))
              ))
           ((string-match
             abbrev-complete-immediately-dabbrev-completion-seg
             (char-to-string (preceding-char)))
            (progn
              (setq abbrev-complete-not-dabbrev-seg-internal (char-to-string (preceding-char)))
              (setq abbrev-complete-do-abbrev nil)
              (delete-region (- (point) 1) (point))
              (setq abbrev-completion-point (point))
              ))
           )
        
          (if (or (= (line-beginning-position) (point))
                  (string-match
                   abbrev-complete-word-seg
                   (buffer-substring (- (point) 1) (point))))
              ()
            (setq abbrev-completion-dabbrev-word (dabbrev--abbrev-at-point)))
        
          ))

      ;; Read word
      (if (= (line-beginning-position) (point))
          (setq pos (point))
        (if (string-match
             abbrev-complete-word-seg
             (buffer-substring (- (point) 1) (point)))
            (setq pos (point))
          (setq pos (save-excursion
                      (forward-word -1)
                      (point)))))
    
      (setq word (buffer-substring-no-properties pos (point)))
    
      ;; no complete by abbrev : abbrev-compl(point)
      (if (and (not abbrev-complete-before-dabbrev)
               (char-before pos)
               (string-match abbrev-complete-not-abbrev-completion-seg
                             (char-to-string (char-before pos)))
               (not (= pos (line-beginning-position))))
          (setq abbrev-complete-before-abbrev t))

      ;; Resete completions list, word, position
      (if (eq last-command this-command)
          ()
        (progn
          ;; Reset completion
          (setq abbrev-complete-start-position pos)
          (setq abbrev-complete-word word)
          (setq abbrev-complete-maybes
                (sort
                 (append
                  (all-completions word global-abbrev-table)
                  (all-completions word local-abbrev-table))
                 'string<))
          (let ((list nil))
            (dolist (elt abbrev-complete-maybes)
              (unless (member elt list)
                (push elt list)))
            (setq abbrev-complete-maybes (nreverse list)))

          (setq abbrev-complete-maybes-all abbrev-complete-maybes)
          (setq abbrev-complete-table (abbrev-complete-make-list abbrev-complete-maybes-all))
          ))

      ;;body
      (if (and
           (or abbrev-complete-before-dabbrev
               (not abbrev-complete-do-abbrev) ;; complete abbrev (session)? -> no
               abbrev-complete-before-abbrev)
           abbrev-complete-no-entry-dabbrev ;; complete dabbrev (user)? -> Yes
           abbrev-complete-do-dabbrev) ;; complete dabbrev (session)? -> Yes
          (progn
            (if abbrev-complete-before-dabbrev
                (abbrev-complete-dabbrev-expand)
              (abbrev-complete-expand-abbrev)))
      
        ;; abbrev-complete-before-dabbrev, abbrev-complete-before-abbrev : nil
        (cond
         ;; No further abbrev-expansion
         ((null abbrev-complete-maybes)
          ;;(save-excursion (goto-char (point-max)) (insert "0 "))
          (delete-region abbrev-complete-start-position abbrev-completion-point) ;;(point))
          (insert abbrev-complete-word)
          (setq abbrev-completion-point (point))

          (if (and abbrev-complete-no-entry-dabbrev
                   abbrev-complete-do-dabbrev)
              (abbrev-complete-expand-abbrev)
            (progn
              (setq word abbrev-complete-word)
              (delete-region abbrev-complete-start-position abbrev-completion-point)
              (insert (concat abbrev-complete-word
                              abbrev-complete-not-dabbrev-seg-internal))
              (setq abbrev-completion-point (point))
              (setq abbrev-complete-maybes
                    (sort
                     (append
                      (all-completions abbrev-complete-word global-abbrev-table)
                      (all-completions abbrev-complete-word local-abbrev-table))
                     'string<))
              (setq abbrev-complete-table (abbrev-complete-make-list abbrev-complete-maybes-all))

              (setq abbrev-complete-maybes-all abbrev-complete-maybes)
              (setq abbrev-complete-before-abbrev nil)
              (message "No further expansion for `%s' found" word)
              )))

         ;; *NOT* after abbrev-complete-word-seg and only one abbrev
         ((and (not (= 0 (length word)))
               (= (length abbrev-complete-maybes) 1))
          ;;(save-excursion (goto-char (point-max)) (insert "1 "))
          (delete-region abbrev-complete-start-position abbrev-completion-point) ;;(point))
          (if (eq abbrev-complete-show-completion 'always)
              (abbrev-complete-display-completion))
          (insert (car abbrev-complete-maybes))
          (setq abbrev-completion-point (point))
          (setq abbrev-complete-before-abbrev t)
          (if  (string= "*Completions*"
                        (buffer-name (window-buffer (next-window))))
              (abbrev-complete-highlight-completions))
          (message "Expansion for '%s'" (car abbrev-complete-maybes))
          (setq abbrev-complete-maybes nil)
          (setq abbrev-complete-table nil)
          ;;(sit-for 0.5) ;; wait 0.5 sec
          )

         ;; After abbrev-complete-word-seg and only one abbrev
         ((and (= 0 (length word))
               (= (length abbrev-complete-maybes) 1))
          ;;(save-excursion (goto-char (point-max)) (insert "2 "))
          (delete-region abbrev-complete-start-position abbrev-completion-point)
          (if (eq abbrev-complete-show-completion 'always)
              (abbrev-complete-display-completion))
          (insert (car abbrev-complete-maybes))
          (setq abbrev-completion-point (point))
          (setq abbrev-complete-before-abbrev t)
          (setq abbrev-complete-maybes nil)
          (setq abbrev-complete-table nil)
          )

         ;; Default
         (t
          ;;(save-excursion (goto-char (point-max)) (insert "3 "))
          (delete-region abbrev-complete-start-position abbrev-completion-point)
          (if (or (eq abbrev-complete-show-completion 'always)
                  (eq abbrev-complete-show-completion t)
                  (and (eq abbrev-complete-show-completion 'view)
                       (= 0 (length word))))
              (abbrev-complete-display-completion))
          (if (and abbrev-complete-completion
                   (not (= 0 (length abbrev-complete-word))))
              (abbrev-complete-car-expand)
            (progn
              (insert (try-completion word  (mapcar 'list abbrev-complete-maybes-all)))
              (setq abbrev-completion-point (point))))
          (setq abbrev-complete-before-abbrev nil))
         ))
      ;;(save-excursion (goto-char (point-max)) (insert "\n"))

      )))


;; Delete *Completions* window
(add-hook 'pre-command-hook
          (lambda ()
            (if (and
                 abbrev-complete-windows-conf
                 (not (eq last-command this-command))
                 (string= "*Completions*"
                          (buffer-name (window-buffer (next-window)))))
                (abbrev-comple-delete-window))
            (setq abbrev-complete-windows-conf nil)))


(provide 'abbrev-complete)
;;; abbrev-complete.el ends here