emacs/nxhtml/util/popcmp.el

   1 ;;; popcmp.el --- Completion enhancements, popup etc
   2 ;;
   3 ;; Author: Lennart Borgman
   4 ;; Created: Tue Jan 09 12:00:29 2007
   5 ;; Version: 1.00
   6 ;; Last-Updated: 2008-03-08T03:30:15+0100 Sat
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   `ourcomments-util'.
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;;
  16 ;;; Commentary:
  17 ;;
  18 ;;
  19 ;;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;
  22 ;;; Change log:
  23 ;;
  24 ;;
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;
  27 ;; This program is free software; you can redistribute it and/or modify
  28 ;; it under the terms of the GNU General Public License as published by
  29 ;; the Free Software Foundation; either version 2, or (at your option)
  30 ;; any later version.
  31 ;;
  32 ;; This program is distributed in the hope that it will be useful,
  33 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  34 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35 ;; GNU General Public License for more details.
  36 ;;
  37 ;; You should have received a copy of the GNU General Public License
  38 ;; along with this program; see the file COPYING.  If not, write to the
  39 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  40 ;; Boston, MA 02111-1307, USA.
  41 ;;
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;
  44 ;;; Code:
  45
  46 (eval-when-compile (require 'cl))
  47 (eval-when-compile (require 'ourcomments-util nil t))
  48
  49 ;;;###autoload
  50 (defgroup popcmp nil
  51   "Customization group for popup completion."
  52   :tag "Completion Style \(popup etc)"
  53   :group 'nxhtml
  54   :group 'convenience)
  55
  56 ;; (define-toggle popcmp-popup-completion t
  57 ;;   "Use a popup menu for some completions if non-nil.
  58
  59 ;; ***** Obsolete: Use `popcmp-completion-style' instead.
  60
  61 ;; When completion is used for alternatives tighed to text at the
  62 ;; point in buffer it may make sense to use a popup menu for
  63 ;; completion.  This variable let you decide whether normal style
  64 ;; completion or popup style completion should be used then.
  65
  66 ;; This style of completion is not implemented for all completions.
  67 ;; It is implemented for specific cases but the choice of completion
  68 ;; style is managed generally by this variable for all these cases.
  69
  70 ;; See also the options `popcmp-short-help-beside-alts' and
  71 ;; `popcmp-group-alternatives' which are also availabe when popup
  72 ;; completion is available."
  73 ;;   :tag "Popup style completion"
  74 ;;   :group 'popcmp)
  75
  76 (defun popcmp-cant-use-style (style)
  77   (save-match-data ;; runs in timer
  78     (describe-variable 'popcmp-completion-style)
  79     (message (propertize "popcmp-completion-style: style `%s' is not available"
  80                          'face 'secondary-selection)
  81              style)))
  82
  83
  84
  85 (defun popcmp-set-completion-style (val)
  86   "Internal use, set `popcmp-completion-style' to VAL."
  87   (assert (memq val '(popcmp-popup emacs-default company-mode anything)) t)
  88   (case val
  89     ('company-mode (unless (fboundp 'company-mode)
  90                      (require 'company-mode nil t))
  91                    (unless (fboundp 'company-mode)
  92                      (run-with-idle-timer 1 nil 'popcmp-cant-use-style val)
  93                      (setq val 'popcmp-popup)))
  94     ('anything     (unless (fboundp 'anything)
  95                      (require 'anything nil t))
  96                    (unless (fboundp 'anything)
  97                      (run-with-idle-timer 1 nil 'popcmp-cant-use-style val)
  98                      (setq val 'popcmp-popup))))
  99   (set-default 'popcmp-completion-style val)
 100   (unless (eq val 'company-mode)
 101     (when (and (boundp 'global-company-mode)
 102                global-company-mode)
 103       (global-company-mode -1))
 104     (remove-hook 'after-change-major-mode-hook 'company-set-major-mode-backend)
 105     (remove-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode))
 106   (when (eq val 'company-mode)
 107     (unless (and (boundp 'global-company-mode)
 108                  global-company-mode)
 109       (global-company-mode 1))
 110     (add-hook 'after-change-major-mode-hook 'company-set-major-mode-backend)
 111     (add-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode)))
 112
 113 ;; fix-me: move to mumamo.el
 114 (defun mumamo-turn-on-company-mode ()
 115   (when (and (boundp 'company-mode)
 116              company-mode)
 117     (company-mode 1)
 118     (company-set-major-mode-backend)))
 119
 120 ;;;###autoload
 121 (defcustom popcmp-completion-style (cond
 122                                     ;;((and (fboundp 'global-company-mode) 'company-mode) 'company-mode)
 123                                     (t 'popcmp-popup))
 124   "Completion style.
 125 The currently available completion styles are:
 126
 127 - popcmp-popup: Use OS popup menus (default).
 128 - emacs-default: Emacs default completion.
 129 - Company Mode completion.
 130 - anything: The Anything elisp lib completion style.
 131
 132 The style of completion set here is not implemented for all
 133 completions.  The scope varies however with which completion
 134 style you have choosen.
 135
 136 For information about Company Mode and how to use it see URL
 137 `http://www.emacswiki.org/emacs/CompanyMode'.
 138
 139 For information about Anything and how to use it see URL
 140 `http://www.emacswiki.org/emacs/Anything'.
 141
 142 See also the options `popcmp-short-help-beside-alts' and
 143 `popcmp-group-alternatives' which are also availabe when popup
 144 completion is available."
 145   :type '(choice (const company-mode)
 146                  (const popcmp-popup)
 147                  (const emacs-default)
 148                  (const anything))
 149   :set (lambda (sym val)
 150          (popcmp-set-completion-style val))
 151   :group 'popcmp)
 152
 153 ;;(define-toggle popcmp-short-help-beside-alts t
 154 (define-minor-mode popcmp-short-help-beside-alts
 155   "Show a short help text beside each alternative.
 156 If this is non-nil a short help text is shown beside each
 157 alternative for which such a help text is available.
 158
 159 This works in the same circumstances as
 160 `popcmp-completion-style'."
 161   :tag "Short help beside alternatives"
 162   :global t
 163   :init-value t
 164   :group 'popcmp)
 165
 166 (defun popcmp-short-help-beside-alts-toggle ()
 167   "Toggle `popcmp-short-help-beside-alts'."
 168   (popcmp-short-help-beside-alts (if popcmp-short-help-beside-alts -1 1)))
 169
 170 ;;(define-toggle popcmp-group-alternatives t
 171 (define-minor-mode popcmp-group-alternatives
 172   "Do completion in two steps.
 173 For some completions the alternatives may have been grouped in
 174 sets. If this option is non-nil then you will first choose a set
 175 and then an alternative within this set.
 176
 177 This works in the same circumstances as
 178 `popcmp-completion-style'."
 179   :tag "Group alternatives"
 180   :global t
 181   :init-value t
 182   :group 'popcmp)
 183
 184 (defun popcmp-group-alternatives-toggle ()
 185   "Toggle `popcmp-group-alternatives-toggle'."
 186   (interactive)
 187   (popcmp-group-alternatives (if popcmp-group-alternatives -1 1)))
 188
 189 (defun popcmp-getsets (alts available-sets)
 190   (let ((sets nil))
 191     (dolist (tg alts)
 192       (let (found)
 193         (dolist (s available-sets)
 194           (when (member tg (cdr s))
 195             (setq found t)
 196             (let ((sets-entry (assq (car s) sets)))
 197               (unless sets-entry
 198                 (setq sets (cons (list (car s)) sets))
 199                 (setq sets-entry (assq (car s) sets)))
 200                   (setcdr sets-entry (cons tg (cdr sets-entry))))))
 201         (unless found
 202           (let ((sets-entry (assq 'unsorted sets)))
 203             (unless sets-entry
 204               (setq sets (cons (list 'unsorted) sets))
 205               (setq sets-entry (assq 'unsorted sets)))
 206             (setcdr sets-entry (cons tg (cdr sets-entry)))))))
 207     (setq sets (sort sets (lambda (a b)
 208                             (string< (format "%s" b)
 209                                      (format "%s" a)))))
 210     ;;(dolist (s sets) (setcdr s (reverse (cdr s))))
 211     sets))
 212
 213 (defun popcmp-getset-alts (set-name sets)
 214   ;; Allow both strings and symbols as keys:
 215   (let ((set (or (assoc (downcase set-name) sets)
 216                  (assoc (read (downcase set-name)) sets))))
 217     (cdr set)))
 218
 219 (defvar popcmp-completing-with-help nil)
 220
 221 (defun popcmp-add-help (alt alt-help-hash)
 222   (if alt-help-hash
 223       (let ((h (if (hash-table-p alt-help-hash)
 224                    (gethash alt alt-help-hash)
 225                  (let ((hh (assoc alt alt-help-hash)))
 226                    (cadr hh)))
 227                  ))
 228         (if h
 229             (concat alt " -- " h)
 230           alt))
 231     alt))
 232
 233 (defun popcmp-remove-help (alt-with-help)
 234   (when alt-with-help
 235     (replace-regexp-in-string " -- .*" "" alt-with-help)))
 236
 237 (defun popcmp-anything (prompt collection
 238                                predicate require-match
 239                                initial-input hist def inherit-input-method
 240                                alt-help alt-sets)
 241   (let* ((table collection)
 242          (alt-sets2 (apply 'append (mapcar 'cdr alt-sets)))
 243          (cands (cond ((not (listp table)) alt-sets2)
 244                      (t table)))
 245          ret-val
 246          (source `((name . "Completion candidates")
 247                    (candidates . ,cands)
 248                    (action . (("Select current alternative (press TAB to see it again)" . (lambda (candidate)
 249                                             (setq ret-val candidate))))))))
 250     (anything (list source) initial-input prompt)
 251     ret-val))
 252
 253 (defun popcmp-completing-read-1 (prompt collection
 254                                         predicate require-match
 255                                         initial-input hist2 def inherit-input-method alt-help alt-sets)
 256   ;; Fix-me: must rename hist to hist2 in par list. Emacs bug?
 257   (cond
 258    ((eq popcmp-completion-style 'emacs-default)
 259     (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method))
 260    ((eq popcmp-completion-style 'anything)
 261     (popcmp-anything prompt collection predicate require-match initial-input hist2 def inherit-input-method
 262                      alt-help alt-sets))
 263    ((eq popcmp-completion-style 'company-mode)
 264     ;; No way to read this from company-mode, use emacs-default
 265     (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method))
 266    (t (error "Do not know popcmp-completion-style %S" popcmp-completion-style))))
 267
 268 (defun popcmp-completing-read-other (prompt
 269                                     table
 270                                     &optional predicate require-match
 271                                     initial-input pop-hist def inherit-input-method
 272                                     alt-help
 273                                     alt-sets)
 274   (let ((alts
 275          (if (and popcmp-group-alternatives alt-sets)
 276              (all-completions initial-input table predicate)
 277            (if popcmp-short-help-beside-alts
 278                (all-completions "" table predicate)
 279              table))))
 280     (when (and popcmp-group-alternatives alt-sets)
 281       (let* ((sets (popcmp-getsets alts alt-sets))
 282              (set-names (mapcar (lambda (elt)
 283                                   (capitalize (format "%s" (car elt))))
 284                                 sets))
 285              set)
 286         (setq set
 287               (popcmp-completing-read-1 (concat
 288                                          (substring prompt 0 (- (length prompt) 2))
 289                                          ", select group: ")
 290                                         set-names
 291                                         nil t
 292                                         nil nil nil inherit-input-method nil nil))
 293         (if (or (not set) (= 0 (length set)))
 294             (setq alts nil)
 295           (setq set (downcase set))
 296           (setq alts (popcmp-getset-alts set sets)))))
 297     (if (not alts)
 298         ""
 299       (if (= 1 (length alts))
 300           (car alts)
 301         (when popcmp-short-help-beside-alts
 302           (setq alts (mapcar (lambda (a)
 303                                (popcmp-add-help a alt-help))
 304                              alts)))
 305         (popcmp-remove-help
 306          ;;(completing-read prompt
 307          (popcmp-completing-read-1 prompt
 308                                    alts ;table
 309                                    predicate require-match
 310                                    initial-input pop-hist def inherit-input-method
 311                                    ;;alt-help alt-sets
 312                                    nil nil
 313                                    ))))))
 314
 315 (defun popcmp-completing-read-pop (prompt
 316                                   table
 317                                   &optional predicate require-match
 318                                   initial-input hist def inherit-input-method
 319                                   alt-help
 320                                   alt-sets)
 321   (unless initial-input
 322     (setq initial-input ""))
 323   (let ((matching-alts (all-completions initial-input table predicate))
 324         completion)
 325     (if (not matching-alts)
 326         (progn
 327           (message "No alternative found")
 328           nil)
 329       (let ((pop-map (make-sparse-keymap prompt))
 330             (sets (when (and popcmp-group-alternatives alt-sets)
 331                     (popcmp-getsets matching-alts alt-sets)))
 332             (add-alt (lambda (k tg)
 333                        (define-key k
 334                          (read (format "[popcmp-%s]" (replace-regexp-in-string " " "-" tg)))
 335                          (list 'menu-item
 336                                (popcmp-add-help tg alt-help)
 337                                `(lambda ()
 338                                   (interactive)
 339                                   (setq completion ,tg)))))))
 340         (if sets
 341             (dolist (s sets)
 342               (let ((k (make-sparse-keymap)))
 343                 (dolist (tg (cdr s))
 344                   (funcall add-alt k tg))
 345                 (define-key pop-map
 346                   (read (format "[popcmps-%s]" (car s)))
 347                   (list 'menu-item
 348                         (capitalize (format "%s" (car s)))
 349                         k))))
 350           (dolist (tg matching-alts)
 351             (funcall add-alt pop-map tg)))
 352         (popup-menu-at-point pop-map)
 353         completion))))
 354
 355 (defvar popcmp-in-buffer-allowed nil)
 356
 357 ;;;###autoload
 358 (defun popcmp-completing-read (prompt
 359                               table
 360                               &optional predicate require-match
 361                               initial-input pop-hist def inherit-input-method
 362                               alt-help
 363                               alt-sets)
 364   "Read a string in the minubuffer with completion, or popup a menu.
 365 This function can be used instead `completing-read'. The main
 366 purpose is to provide a popup style menu for completion when
 367 completion is tighed to text at point in a buffer. If a popup
 368 menu is used it will be shown at window point. Whether a popup
 369 menu or minibuffer completion is used is governed by
 370 `popcmp-completion-style'.
 371
 372 The variables PROMPT, TABLE, PREDICATE, REQUIRE-MATCH,
 373 INITIAL-INPUT, POP-HIST, DEF and INHERIT-INPUT-METHOD all have the
 374 same meaning is for `completing-read'.
 375
 376 ALT-HELP should be nil or a hash variable or an association list
 377 with the completion alternative as key and a short help text as
 378 value.  You do not need to supply help text for all alternatives.
 379 The use of ALT-HELP is set by `popcmp-short-help-beside-alts'.
 380
 381 ALT-SETS should be nil or an association list that has as keys
 382 groups and as second element an alternative that should go into
 383 this group.
 384 "
 385   (if (and popcmp-in-buffer-allowed
 386            (eq popcmp-completion-style 'company-mode)
 387            (boundp 'company-mode)
 388            company-mode)
 389       (progn
 390         (add-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion t)
 391         ;;(remove-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion)
 392         (call-interactively 'company-nxml)
 393         initial-input)
 394
 395     (popcmp-mark-completing initial-input)
 396     (let ((err-sym 'quit)
 397           (err-val nil)
 398           ret)
 399       (unwind-protect
 400           (if (eq popcmp-completion-style 'popcmp-popup)
 401               (progn
 402                 (setq err-sym nil)
 403                 (popcmp-completing-read-pop
 404                  prompt
 405                  table
 406                  predicate require-match
 407                  initial-input pop-hist def inherit-input-method
 408                  alt-help
 409                  alt-sets))
 410             ;;(condition-case err
 411                 (prog1
 412                     (setq ret (popcmp-completing-read-other
 413                                prompt
 414                                table
 415                                predicate require-match
 416                                initial-input pop-hist def inherit-input-method
 417                                alt-help
 418                                alt-sets))
 419                   ;; Unless quit or error in Anything we come here:
 420                   ;;(message "ret=(%S)" ret)
 421                   (when (and ret (not (string= ret "")))
 422                     (setq err-sym nil)))
 423               ;; (error
 424               ;;  ;;(message "err=%S" err)
 425               ;;  (setq err-sym (car err))
 426               ;;  (setq err-val (cdr err))))
 427                 )
 428         (popcmp-unmark-completing)
 429         (when err-sym (signal err-sym err-val))))))
 430
 431 (defvar popcmp-mark-completing-ovl nil)
 432
 433 (defun popcmp-mark-completing (initial-input)
 434   (let ((start (- (point) (length initial-input)))
 435         (end (point)))
 436     (if (overlayp popcmp-mark-completing-ovl)
 437         (move-overlay popcmp-mark-completing-ovl start end)
 438       (setq popcmp-mark-completing-ovl (make-overlay start end))
 439       (overlay-put popcmp-mark-completing-ovl 'face 'match)))
 440   (sit-for 0))
 441
 442 (defun popcmp-unmark-completing ()
 443   (when popcmp-mark-completing-ovl
 444     (delete-overlay popcmp-mark-completing-ovl)))
 445
 446
 447 ;; (defun popcmp-temp ()
 448 ;;   (interactive)
 449 ;;   (let* ((coord (point-to-coord (point)))
 450 ;;          (x (nth 0 (car coord)))
 451 ;;          (y (nth 1 (car coord)))
 452 ;;          (emacsw32-max-frames nil)
 453 ;;          (f (make-frame
 454 ;;              (list '(minibuffer . only)
 455 ;;                    '(title . "Input")
 456 ;;                    '(name . "Input frame")
 457 ;;                    (cons 'left x)
 458 ;;                    (cons 'top y)
 459 ;;                    '(height . 1)
 460 ;;                    '(width . 40)
 461 ;;                    '(border-width . 1)
 462 ;;                    '(internal-border-width . 2)
 463 ;;                    '(tool-bar-lines . nil)
 464 ;;                    '(menu-bar-lines . nil)
 465 ;;                    ))))
 466 ;;     f))
 467
 468
 469 (provide 'popcmp)
 470
 471 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 472 ;;; popcmp.el ends here