;;; 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