path: root/emacs.d/nxhtml/util/popcmp.el

;;; popcmp.el --- Completion enhancements, popup etc
;;
;; Author: Lennart Borgman
;; Created: Tue Jan 09 12:00:29 2007
;; Version: 1.00
;; Last-Updated: 2008-03-08T03:30:15+0100 Sat
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
;;   `ourcomments-util'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 2, 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(eval-when-compile (require 'cl))
(eval-when-compile (require 'ourcomments-util nil t))

;;;###autoload
(defgroup popcmp nil
  "Customization group for popup completion."
  :tag "Completion Style \(popup etc)"
  :group 'nxhtml
  :group 'convenience)

;; (define-toggle popcmp-popup-completion t
;;   "Use a popup menu for some completions if non-nil.

;; ***** Obsolete: Use `popcmp-completion-style' instead.

;; When completion is used for alternatives tighed to text at the
;; point in buffer it may make sense to use a popup menu for
;; completion.  This variable let you decide whether normal style
;; completion or popup style completion should be used then.

;; This style of completion is not implemented for all completions.
;; It is implemented for specific cases but the choice of completion
;; style is managed generally by this variable for all these cases.

;; See also the options `popcmp-short-help-beside-alts' and
;; `popcmp-group-alternatives' which are also availabe when popup
;; completion is available."
;;   :tag "Popup style completion"
;;   :group 'popcmp)

(defun popcmp-cant-use-style (style)
  (save-match-data ;; runs in timer
    (describe-variable 'popcmp-completion-style)
    (message (propertize "popcmp-completion-style: style `%s' is not available"
                         'face 'secondary-selection)
             style)))



(defun popcmp-set-completion-style (val)
  "Internal use, set `popcmp-completion-style' to VAL."
  (assert (memq val '(popcmp-popup emacs-default company-mode anything)) t)
  (case val
    ('company-mode (unless (fboundp 'company-mode)
                     (require 'company-mode nil t))
                   (unless (fboundp 'company-mode)
                     (run-with-idle-timer 1 nil 'popcmp-cant-use-style val)
                     (setq val 'popcmp-popup)))
    ('anything     (unless (fboundp 'anything)
                     (require 'anything nil t))
                   (unless (fboundp 'anything)
                     (run-with-idle-timer 1 nil 'popcmp-cant-use-style val)
                     (setq val 'popcmp-popup))))
  (set-default 'popcmp-completion-style val)
  (unless (eq val 'company-mode)
    (when (and (boundp 'global-company-mode)
               global-company-mode)
      (global-company-mode -1))
    (remove-hook 'after-change-major-mode-hook 'company-set-major-mode-backend)
    (remove-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode))
  (when (eq val 'company-mode)
    (unless (and (boundp 'global-company-mode)
                 global-company-mode)
      (global-company-mode 1))
    (add-hook 'after-change-major-mode-hook 'company-set-major-mode-backend)
    (add-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode)))

;; fix-me: move to mumamo.el
(defun mumamo-turn-on-company-mode ()
  (when (and (boundp 'company-mode)
             company-mode)
    (company-mode 1)
    (company-set-major-mode-backend)))

;;;###autoload
(defcustom popcmp-completion-style (cond
                                    ;;((and (fboundp 'global-company-mode) 'company-mode) 'company-mode)
                                    (t 'popcmp-popup))
  "Completion style.
The currently available completion styles are:

- popcmp-popup: Use OS popup menus (default).
- emacs-default: Emacs default completion.
- Company Mode completion.
- anything: The Anything elisp lib completion style.

The style of completion set here is not implemented for all
completions.  The scope varies however with which completion
style you have choosen.

For information about Company Mode and how to use it see URL
`http://www.emacswiki.org/emacs/CompanyMode'.

For information about Anything and how to use it see URL
`http://www.emacswiki.org/emacs/Anything'.

See also the options `popcmp-short-help-beside-alts' and
`popcmp-group-alternatives' which are also availabe when popup
completion is available."
  :type '(choice (const company-mode)
                 (const popcmp-popup)
                 (const emacs-default)
                 (const anything))
  :set (lambda (sym val)
         (popcmp-set-completion-style val))
  :group 'popcmp)

;;(define-toggle popcmp-short-help-beside-alts t
(define-minor-mode popcmp-short-help-beside-alts
  "Show a short help text beside each alternative.
If this is non-nil a short help text is shown beside each
alternative for which such a help text is available.

This works in the same circumstances as
`popcmp-completion-style'."
  :tag "Short help beside alternatives"
  :global t
  :init-value t
  :group 'popcmp)

(defun popcmp-short-help-beside-alts-toggle ()
  "Toggle `popcmp-short-help-beside-alts'."
  (popcmp-short-help-beside-alts (if popcmp-short-help-beside-alts -1 1)))

;;(define-toggle popcmp-group-alternatives t
(define-minor-mode popcmp-group-alternatives
  "Do completion in two steps.
For some completions the alternatives may have been grouped in
sets. If this option is non-nil then you will first choose a set
and then an alternative within this set.

This works in the same circumstances as
`popcmp-completion-style'."
  :tag "Group alternatives"
  :global t
  :init-value t
  :group 'popcmp)

(defun popcmp-group-alternatives-toggle ()
  "Toggle `popcmp-group-alternatives-toggle'."
  (interactive)
  (popcmp-group-alternatives (if popcmp-group-alternatives -1 1)))

(defun popcmp-getsets (alts available-sets)
  (let ((sets nil))
    (dolist (tg alts)
      (let (found)
        (dolist (s available-sets)
          (when (member tg (cdr s))
            (setq found t)
            (let ((sets-entry (assq (car s) sets)))
              (unless sets-entry
                (setq sets (cons (list (car s)) sets))
                (setq sets-entry (assq (car s) sets)))
                  (setcdr sets-entry (cons tg (cdr sets-entry))))))
        (unless found
          (let ((sets-entry (assq 'unsorted sets)))
            (unless sets-entry
              (setq sets (cons (list 'unsorted) sets))
              (setq sets-entry (assq 'unsorted sets)))
            (setcdr sets-entry (cons tg (cdr sets-entry)))))))
    (setq sets (sort sets (lambda (a b)
                            (string< (format "%s" b)
                                     (format "%s" a)))))
    ;;(dolist (s sets) (setcdr s (reverse (cdr s))))
    sets))

(defun popcmp-getset-alts (set-name sets)
  ;; Allow both strings and symbols as keys:
  (let ((set (or (assoc (downcase set-name) sets)
                 (assoc (read (downcase set-name)) sets))))
    (cdr set)))

(defvar popcmp-completing-with-help nil)

(defun popcmp-add-help (alt alt-help-hash)
  (if alt-help-hash
      (let ((h (if (hash-table-p alt-help-hash)
                   (gethash alt alt-help-hash)
                 (let ((hh (assoc alt alt-help-hash)))
                   (cadr hh)))
                 ))
        (if h
            (concat alt " -- " h)
          alt))
    alt))

(defun popcmp-remove-help (alt-with-help)
  (when alt-with-help
    (replace-regexp-in-string " -- .*" "" alt-with-help)))

(defun popcmp-anything (prompt collection
                               predicate require-match
                               initial-input hist def inherit-input-method
                               alt-help alt-sets)
  (let* ((table collection)
         (alt-sets2 (apply 'append (mapcar 'cdr alt-sets)))
         (cands (cond ((not (listp table)) alt-sets2)
                     (t table)))
         ret-val
         (source `((name . "Completion candidates")
                   (candidates . ,cands)
                   (action . (("Select current alternative (press TAB to see it again)" . (lambda (candidate)
                                            (setq ret-val candidate))))))))
    (anything (list source) initial-input prompt)
    ret-val))

(defun popcmp-completing-read-1 (prompt collection
                                        predicate require-match
                                        initial-input hist2 def inherit-input-method alt-help alt-sets)
  ;; Fix-me: must rename hist to hist2 in par list. Emacs bug?
  (cond
   ((eq popcmp-completion-style 'emacs-default)
    (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method))
   ((eq popcmp-completion-style 'anything)
    (popcmp-anything prompt collection predicate require-match initial-input hist2 def inherit-input-method
                     alt-help alt-sets))
   ((eq popcmp-completion-style 'company-mode)
    ;; No way to read this from company-mode, use emacs-default
    (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method))
   (t (error "Do not know popcmp-completion-style %S" popcmp-completion-style))))

(defun popcmp-completing-read-other (prompt
                                    table
                                    &optional predicate require-match
                                    initial-input pop-hist def inherit-input-method
                                    alt-help
                                    alt-sets)
  (let ((alts
         (if (and popcmp-group-alternatives alt-sets)
             (all-completions initial-input table predicate)
           (if popcmp-short-help-beside-alts
               (all-completions "" table predicate)
             table))))
    (when (and popcmp-group-alternatives alt-sets)
      (let* ((sets (popcmp-getsets alts alt-sets))
             (set-names (mapcar (lambda (elt)
                                  (capitalize (format "%s" (car elt))))
                                sets))
             set)
        (setq set
              (popcmp-completing-read-1 (concat
                                         (substring prompt 0 (- (length prompt) 2))
                                         ", select group: ")
                                        set-names
                                        nil t
                                        nil nil nil inherit-input-method nil nil))
        (if (or (not set) (= 0 (length set)))
            (setq alts nil)
          (setq set (downcase set))
          (setq alts (popcmp-getset-alts set sets)))))
    (if (not alts)
        ""
      (if (= 1 (length alts))
          (car alts)
        (when popcmp-short-help-beside-alts
          (setq alts (mapcar (lambda (a)
                               (popcmp-add-help a alt-help))
                             alts)))
        (popcmp-remove-help
         ;;(completing-read prompt
         (popcmp-completing-read-1 prompt
                                   alts ;table
                                   predicate require-match
                                   initial-input pop-hist def inherit-input-method
                                   ;;alt-help alt-sets
                                   nil nil
                                   ))))))

(defun popcmp-completing-read-pop (prompt
                                  table
                                  &optional predicate require-match
                                  initial-input hist def inherit-input-method
                                  alt-help
                                  alt-sets)
  (unless initial-input
    (setq initial-input ""))
  (let ((matching-alts (all-completions initial-input table predicate))
        completion)
    (if (not matching-alts)
        (progn
          (message "No alternative found")
          nil)
      (let ((pop-map (make-sparse-keymap prompt))
            (sets (when (and popcmp-group-alternatives alt-sets)
                    (popcmp-getsets matching-alts alt-sets)))
            (add-alt (lambda (k tg)
                       (define-key k
                         (read (format "[popcmp-%s]" (replace-regexp-in-string " " "-" tg)))
                         (list 'menu-item
                               (popcmp-add-help tg alt-help)
                               `(lambda ()
                                  (interactive)
                                  (setq completion ,tg)))))))
        (if sets
            (dolist (s sets)
              (let ((k (make-sparse-keymap)))
                (dolist (tg (cdr s))
                  (funcall add-alt k tg))
                (define-key pop-map
                  (read (format "[popcmps-%s]" (car s)))
                  (list 'menu-item
                        (capitalize (format "%s" (car s)))
                        k))))
          (dolist (tg matching-alts)
            (funcall add-alt pop-map tg)))
        (popup-menu-at-point pop-map)
        completion))))

(defvar popcmp-in-buffer-allowed nil)

;;;###autoload
(defun popcmp-completing-read (prompt
                              table
                              &optional predicate require-match
                              initial-input pop-hist def inherit-input-method
                              alt-help
                              alt-sets)
  "Read a string in the minubuffer with completion, or popup a menu.
This function can be used instead `completing-read'. The main
purpose is to provide a popup style menu for completion when
completion is tighed to text at point in a buffer. If a popup
menu is used it will be shown at window point. Whether a popup
menu or minibuffer completion is used is governed by
`popcmp-completion-style'.

The variables PROMPT, TABLE, PREDICATE, REQUIRE-MATCH,
INITIAL-INPUT, POP-HIST, DEF and INHERIT-INPUT-METHOD all have the
same meaning is for `completing-read'.

ALT-HELP should be nil or a hash variable or an association list
with the completion alternative as key and a short help text as
value.  You do not need to supply help text for all alternatives.
The use of ALT-HELP is set by `popcmp-short-help-beside-alts'.

ALT-SETS should be nil or an association list that has as keys
groups and as second element an alternative that should go into
this group.
"
  (if (and popcmp-in-buffer-allowed
           (eq popcmp-completion-style 'company-mode)
           (boundp 'company-mode)
           company-mode)
      (progn
        (add-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion t)
        ;;(remove-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion)
        (call-interactively 'company-nxml)
        initial-input)

    (popcmp-mark-completing initial-input)
    (let ((err-sym 'quit)
          (err-val nil)
          ret)
      (unwind-protect
          (if (eq popcmp-completion-style 'popcmp-popup)
              (progn
                (setq err-sym nil)
                (popcmp-completing-read-pop
                 prompt
                 table
                 predicate require-match
                 initial-input pop-hist def inherit-input-method
                 alt-help
                 alt-sets))
            ;;(condition-case err
                (prog1
                    (setq ret (popcmp-completing-read-other
                               prompt
                               table
                               predicate require-match
                               initial-input pop-hist def inherit-input-method
                               alt-help
                               alt-sets))
                  ;; Unless quit or error in Anything we come here:
                  ;;(message "ret=(%S)" ret)
                  (when (and ret (not (string= ret "")))
                    (setq err-sym nil)))
              ;; (error
              ;;  ;;(message "err=%S" err)
              ;;  (setq err-sym (car err))
              ;;  (setq err-val (cdr err))))
                )
        (popcmp-unmark-completing)
        (when err-sym (signal err-sym err-val))))))

(defvar popcmp-mark-completing-ovl nil)

(defun popcmp-mark-completing (initial-input)
  (let ((start (- (point) (length initial-input)))
        (end (point)))
    (if (overlayp popcmp-mark-completing-ovl)
        (move-overlay popcmp-mark-completing-ovl start end)
      (setq popcmp-mark-completing-ovl (make-overlay start end))
      (overlay-put popcmp-mark-completing-ovl 'face 'match)))
  (sit-for 0))

(defun popcmp-unmark-completing ()
  (when popcmp-mark-completing-ovl
    (delete-overlay popcmp-mark-completing-ovl)))


;; (defun popcmp-temp ()
;;   (interactive)
;;   (let* ((coord (point-to-coord (point)))
;;          (x (nth 0 (car coord)))
;;          (y (nth 1 (car coord)))
;;          (emacsw32-max-frames nil)
;;          (f (make-frame
;;              (list '(minibuffer . only)
;;                    '(title . "Input")
;;                    '(name . "Input frame")
;;                    (cons 'left x)
;;                    (cons 'top y)
;;                    '(height . 1)
;;                    '(width . 40)
;;                    '(border-width . 1)
;;                    '(internal-border-width . 2)
;;                    '(tool-bar-lines . nil)
;;                    '(menu-bar-lines . nil)
;;                    ))))
;;     f))


(provide 'popcmp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; popcmp.el ends here