home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / complete-1.04.el < prev    next >
Encoding:
Text File  |  1992-07-22  |  13.6 KB  |  426 lines
  1. ;; Partial completion mechanism for GNU Emacs.  Version 1.04.
  2. ;; Copyright (C) 1990 Dave Gillespie, daveg@csvax.caltech.edu.
  3. ;; Special thanks to Hallvard Furuseth for his many ideas and contributions.
  4.  
  5. ;; LCD Archive Entry:
  6. ;; complete|Dave Gillespie|daveg@csvax.caltech.edu|
  7. ;; Partial completion mechanism for GNU Emacs.|
  8. ;; 1.04|92-06-30|~/misc/complete-1.04.el.Z|
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  14. ;; accepts responsibility to anyone for the consequences of using it
  15. ;; or for whether it serves any particular purpose or works at all,
  16. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  17. ;; License for full details.
  18.  
  19. ;; Everyone is granted permission to copy, modify and redistribute
  20. ;; GNU Emacs, but only under the conditions described in the
  21. ;; GNU Emacs General Public License.   A copy of this license is
  22. ;; supposed to have been given to you along with GNU Emacs so you
  23. ;; can know your rights and responsibilities.  It should be in a
  24. ;; file named COPYING.  Among other things, the copyright notice
  25. ;; and this notice must be preserved on all copies.
  26.  
  27.  
  28. ;; Extended completion for the Emacs minibuffer.
  29. ;;
  30. ;; The basic idea is that the command name or other completable text is
  31. ;; divided into words and each word is completed separately, so that
  32. ;; "M-x p-b" expands to "M-x print-buffer".  If the entry is ambiguous
  33. ;; each word is completed as much as possible and then the cursor is
  34. ;; left at the first position where typing another letter will resolve
  35. ;; the ambiguity.
  36. ;;
  37. ;; Word separators for this purpose are hyphen, space, and period.
  38. ;; These would most likely occur in command names, Info menu items,
  39. ;; and file names, respectively.  But all word separators are treated
  40. ;; alike at all times.
  41. ;;
  42. ;; This completion package installs itself on Meta- key sequences by
  43. ;; default, but many people prefer to replace the old-style completer
  44. ;; outright.  You can do this by setting PC-meta-flag as described below.
  45.  
  46.  
  47. ;; Usage:  Load this file.  Now, during completable minibuffer entry,
  48. ;;
  49. ;;     M-TAB    means to do a partial completion;
  50. ;;     M-SPC    means to do a partial complete-word;
  51. ;;     M-RET    means to do a partial complete-and-exit;
  52. ;;     M-?      means to do a partial completion-help.
  53. ;;
  54. ;; If you set PC-meta-flag non-nil, then TAB, SPC, RET, and ? perform
  55. ;; these functions, and M-TAB etc. perform original Emacs completion.
  56. ;; To do this, put the command,
  57. ;;
  58. ;;       (setq PC-meta-flag t)
  59. ;;
  60. ;; in your .emacs file.  To load partial completion automatically, put
  61. ;;
  62. ;;       (load "complete")
  63. ;;
  64. ;; in your .emacs file, too.  Things will be faster if you byte-compile
  65. ;; this file when you install it.
  66. ;;
  67. ;; As an extra feature, in cases where RET would not normally
  68. ;; complete (such as `C-x b'), the M-RET key will always do a partial
  69. ;; complete-and-exit.  Thus `C-x b f.c RET' will select or create a
  70. ;; buffer called "f.c", but `C-x b f.c M-RET' will select the existing
  71. ;; buffer whose name matches that pattern (perhaps "filing.c").
  72. ;; (PC-meta-flag does not affect this behavior; M-RET used to be
  73. ;; undefined in this situation.)
  74.  
  75.  
  76. (defvar PC-meta-flag nil
  77.   "*If nil, TAB does normal Emacs completion and M-TAB does Partial Completion.
  78. If t, TAB does Partial Completion and M-TAB does normal completion.")
  79.  
  80.  
  81. (defvar PC-default-bindings t
  82.   "Set this to nil to suppress the default partial completion key bindings.")
  83.  
  84. (if PC-default-bindings (progn
  85. (define-key minibuffer-local-completion-map "\t" 'PC-complete)
  86. (define-key minibuffer-local-completion-map " "  'PC-complete-word)
  87. (define-key minibuffer-local-completion-map "?"  'PC-completion-help)
  88.  
  89. (define-key minibuffer-local-completion-map "\e\t" 'PC-complete)
  90. (define-key minibuffer-local-completion-map "\e "  'PC-complete-word)
  91. (define-key minibuffer-local-completion-map "\e\r" 'PC-force-complete-and-exit)
  92. (define-key minibuffer-local-completion-map "\e\n" 'PC-force-complete-and-exit)
  93. (define-key minibuffer-local-completion-map "\e?"  'PC-completion-help)
  94.  
  95. (define-key minibuffer-local-must-match-map "\t" 'PC-complete)
  96. (define-key minibuffer-local-must-match-map " "  'PC-complete-word)
  97. (define-key minibuffer-local-must-match-map "\r" 'PC-complete-and-exit)
  98. (define-key minibuffer-local-must-match-map "\n" 'PC-complete-and-exit)
  99. (define-key minibuffer-local-must-match-map "?"  'PC-completion-help)
  100.  
  101. (define-key minibuffer-local-must-match-map "\e\t" 'PC-complete)
  102. (define-key minibuffer-local-must-match-map "\e "  'PC-complete-word)
  103. (define-key minibuffer-local-must-match-map "\e\r" 'PC-complete-and-exit)
  104. (define-key minibuffer-local-must-match-map "\e\n" 'PC-complete-and-exit)
  105. (define-key minibuffer-local-must-match-map "\e?"  'PC-completion-help)
  106. ))
  107.  
  108.  
  109. (defun PC-complete ()
  110.   "Like minibuffer-complete, but allows \"b--di\"-style abbreviations.
  111. For example, \"M-x b--di\" would match \"byte-recompile-directory\", or any
  112. name which consists of three or more words, the first beginning with \"b\"
  113. and the third beginning with \"di\".
  114.  
  115. The pattern \"b--d\" is ambiguous for \"byte-recompile-directory\" and
  116. \"beginning-of-defun\", so this would produce a list of completions
  117. just like when normal Emacs completions are ambiguous.
  118.  
  119. Word-delimiters for the purposes of Partial Completion are \"-\", \".\", and SPC."
  120.   (interactive)
  121.   (if (eq (or (> (length (this-command-keys)) 1)
  122.           (> (aref (this-command-keys) 0) 128)) PC-meta-flag)
  123.       (minibuffer-complete)
  124.     (PC-do-completion nil))
  125. )
  126.  
  127.  
  128. (defun PC-complete-word ()
  129.   "Like minibuffer-complete-word, but allows \"b--di\"-style abbreviations.
  130. See PC-complete for details."
  131.   (interactive)
  132.   (if (eq (or (> (length (this-command-keys)) 1)
  133.           (> (aref (this-command-keys) 0) 128)) PC-meta-flag)
  134.       (if (= last-command-char ? )
  135.       (minibuffer-complete-word)
  136.     (self-insert-command 1))
  137.     (self-insert-command 1)
  138.     (if (eobp)
  139.     (PC-do-completion 'word)))
  140. )
  141.  
  142.  
  143. (defun PC-complete-and-exit ()
  144.   "Like minibuffer-complete-and-exit, but allows \"b--di\"-style abbreviations.
  145. See PC-complete for details."
  146.   (interactive)
  147.   (if (eq (or (> (length (this-command-keys)) 1)
  148.           (> (aref (this-command-keys) 0) 128)) PC-meta-flag)
  149.       (minibuffer-complete-and-exit)
  150.     (PC-do-complete-and-exit))
  151. )
  152.  
  153. (defun PC-force-complete-and-exit ()
  154.   "Like minibuffer-complete-and-exit, but allows \"b--di\"-style abbreviations.
  155. See PC-complete for details."
  156.   (interactive)
  157.   (let ((minibuffer-completion-confirm nil))
  158.     (PC-do-complete-and-exit))
  159. )
  160.  
  161. (defun PC-do-complete-and-exit ()
  162.   (if (= (buffer-size) 0)  ; Duplicate the "bug" that Info-menu relies on...
  163.       (exit-minibuffer)
  164.     (let ((flag (PC-do-completion 'exit)))
  165.       (and flag
  166.        (if (or (eq flag 'complete)
  167.            (not minibuffer-completion-confirm))
  168.            (exit-minibuffer)
  169.          (temp-minibuffer-message " (Confirm)")))))
  170. )
  171.  
  172.  
  173. (defun PC-completion-help ()
  174.   "Like minibuffer-completion-help, but allows \"b--di\"-style abbreviations.
  175. See PC-complete for details."
  176.   (interactive)
  177.   (if (eq (or (> (length (this-command-keys)) 1)
  178.           (> (aref (this-command-keys) 0) 128)) PC-meta-flag)
  179.       (minibuffer-completion-help)
  180.     (PC-do-completion 'help))
  181. )
  182.  
  183.  
  184. (defun PC-do-completion (&optional mode)
  185.   (let* ((table minibuffer-completion-table)
  186.      (pred minibuffer-completion-predicate)
  187.      (filename (eq table 'read-file-name-internal))
  188.      (dirname nil)
  189.      (str (buffer-string))
  190.      basestr
  191.      regex
  192.      (p 0)
  193.      (poss nil)
  194.      helpposs
  195.      (case-fold-search completion-ignore-case))
  196.  
  197.     ;; Check if buffer contents can already be considered complete
  198.     (if (and (eq mode 'exit)
  199.          (PC-is-complete-p str table pred))
  200.     'complete
  201.  
  202.       ;; Strip directory name if appropriate
  203.       (if filename
  204.       (setq basestr (file-name-nondirectory str)
  205.         dirname (file-name-directory str))
  206.     (setq basestr str))
  207.  
  208.       ;; Convert search pattern to a standard regular expression
  209.       (setq regex (regexp-quote basestr))
  210.       (while (setq p (string-match "[-. ]" regex p))
  211.     (if (eq (aref regex p) ? )
  212.         (setq regex (concat (substring regex 0 p)
  213.                 "[^-. ]*[-. ]"
  214.                 (substring regex (1+ p)))
  215.           p (+ p 12))
  216.       (let ((bump (if (eq (aref regex p) ?-) 0 -1)))
  217.         (setq regex (concat (substring regex 0 (+ p bump))
  218.                 "[^-. ]*"
  219.                 (substring regex (+ p bump)))
  220.           p (+ p 8)))))
  221.       (setq regex (concat "\\`" regex))
  222.  
  223.       ;; Find an initial list of possible completions
  224.       (if (not (setq p (string-match "[-. ]" str (length dirname))))
  225.  
  226.       ;; Minibuffer contains no hyphens -- simple case!
  227.       (setq poss (all-completions str
  228.                       table
  229.                       pred))
  230.  
  231.     ;; Use all-completions to do an initial cull.  This is a big win,
  232.     ;; since all-completions is written in C!
  233.     (let ((compl (all-completions (substring str 0 p)
  234.                       table
  235.                       pred)))
  236.       (setq p compl)
  237.       (while p
  238.         (and (string-match regex (car p))
  239.          (setq poss (cons (car p) poss)))
  240.         (setq p (cdr p)))))
  241.  
  242.       ;; Now we have a list of possible completions
  243.       (cond
  244.  
  245.        ;; No valid completions found
  246.        ((null poss)
  247.     (if (and (eq mode 'word)
  248.          (not PC-word-failed-flag))
  249.         (let ((PC-word-failed-flag t))
  250.           (delete-backward-char 1)
  251.           (PC-do-completion 'word))
  252.       (beep)
  253.       (temp-minibuffer-message (if (eq mode 'help)
  254.                        " (No completions)"
  255.                      " (No match)"))
  256.       nil))
  257.  
  258.        ;; More than one valid completion found
  259.        ((or (cdr (setq helpposs poss))
  260.         (memq mode '(help word)))
  261.  
  262.     ;; Handle completion-ignored-extensions
  263.     (and filename
  264.          (not (eq mode 'help))
  265.          (let ((p2 poss))
  266.  
  267.            ;; Build a regular expression representing the extensions list
  268.            (or (equal completion-ignored-extensions PC-ignored-extensions)
  269.            (setq PC-ignored-regexp
  270.              (concat "\\("
  271.                  (mapconcat
  272.                   'regexp-quote
  273.                   (setq PC-ignored-extensions
  274.                     completion-ignored-extensions)
  275.                   "\\|")
  276.                  "\\)\\'")))
  277.  
  278.            ;; Check if there are any without an ignored extension
  279.            (setq p nil)
  280.            (while p2
  281.          (or (string-match PC-ignored-regexp (car p2))
  282.              (setq p (cons (car p2) p)))
  283.          (setq p2 (cdr p2)))
  284.  
  285.            ;; If there are "good" names, use them
  286.            (and p (setq poss p))))
  287.  
  288.     ;; Is the actual string one of the possible completions?
  289.     (setq p (and (not (eq mode 'help)) poss))
  290.     (while (and p
  291.             (not (equal (car p) basestr)))
  292.       (setq p (cdr p)))
  293.     (if p
  294.  
  295.         (progn
  296.           (if (null mode)
  297.           (temp-minibuffer-message " (Complete, but not unique)"))
  298.           t)
  299.  
  300.       ;; If ambiguous, try for a partial completion
  301.       (let ((improved nil)
  302.         prefix
  303.         (pt nil)
  304.         (skip "\\`"))
  305.  
  306.         ;; Check if next few letters are the same in all cases
  307.         (if (and (not (eq mode 'help))
  308.              (setq prefix (try-completion "" (mapcar 'list poss))))
  309.         (let (i)
  310.           (if (eq mode 'word)
  311.               (setq prefix (PC-chop-word prefix basestr)))
  312.           (goto-char (+ (point-min) (length dirname)))
  313.           (while (and (progn
  314.                 (setq i 0)
  315.                 (while (< i (length prefix))
  316.                   (if (eq (aref prefix i) (following-char))
  317.                       (forward-char 1)
  318.                     (if (or (and (looking-at " ")
  319.                          (memq (aref prefix i)
  320.                                '(?- ?. ? )))
  321.                         (eq (downcase (aref prefix i))
  322.                         (downcase (following-char))))
  323.                     (delete-char 1)
  324.                       (setq improved t))
  325.                     (insert (substring prefix i (1+ i))))
  326.                   (setq i (1+ i)))
  327.                 (or pt (setq pt (point)))
  328.                 (looking-at "[-. ]"))
  329.                   (not (eq mode 'word))
  330.                   (setq skip (concat skip
  331.                          (regexp-quote prefix)
  332.                          "[^-. ]*")
  333.                     prefix (try-completion
  334.                         ""
  335.                         (mapcar
  336.                          (function
  337.                           (lambda (x)
  338.                         (list
  339.                          (and (string-match skip x)
  340.                               (substring
  341.                                x
  342.                                (match-end 0))))))
  343.                          poss)))
  344.                   (or (> i 0) (> (length prefix) 0))))
  345.           (goto-char (if (eq mode 'word) (point-max) pt))))
  346.  
  347.         (if (and (eq mode 'word)
  348.              (not PC-word-failed-flag))
  349.  
  350.         (if improved
  351.  
  352.             ;; We changed it... would it be complete without the space?
  353.             (if (PC-is-complete-p (buffer-substring 1 (1- (point-max)))
  354.                       table pred)
  355.             (delete-region (1- (point-max)) (point-max))))
  356.  
  357.           (if improved
  358.  
  359.           ;; We changed it... enough to be complete?
  360.           (and (eq mode 'exit)
  361.                (PC-is-complete-p (buffer-string) table pred))
  362.  
  363.         ;; If totally ambiguous, display a list of completions
  364.         (if (or completion-auto-help
  365.             (eq mode 'help))
  366.             (with-output-to-temp-buffer " *Completions*"
  367.               (display-completion-list (sort helpposs 'string-lessp)))
  368.           (temp-minibuffer-message " (Next char not unique)"))
  369.         nil)))))
  370.  
  371.        ;; Only one possible completion
  372.        (t
  373.     (if (equal basestr (car poss))
  374.         (if (null mode)
  375.         (temp-minibuffer-message " (Sole completion)"))
  376.       (erase-buffer)
  377.       (insert (if filename
  378.               (substitute-in-file-name (concat dirname (car poss)))
  379.             (car poss))))
  380.     t))))
  381. )
  382. (setq PC-ignored-extensions 'empty-cache)
  383. (setq PC-word-failed-flag nil)
  384.  
  385.  
  386. (defun PC-is-complete-p (str table pred)
  387.   (let ((res (if (listp table)
  388.          (assoc str table)
  389.            (if (vectorp table)
  390.            (or (equal str "nil")   ; heh, heh, heh
  391.                (intern-soft str table))
  392.          (funcall table str pred 'lambda)))))
  393.     (and (or (not pred)
  394.          (and (not (listp table)) (not (vectorp table)))
  395.          (funcall pred res))
  396.      res))
  397. )
  398.  
  399. (defun PC-chop-word (new old)
  400.   (let ((i -1)
  401.     (j -1))
  402.     (while (and (setq i (string-match "[-. ]" old (1+ i)))
  403.         (setq j (string-match "[-. ]" new (1+ j)))))
  404.     (if (and j
  405.          (or (not PC-word-failed-flag)
  406.          (setq j (string-match "[-. ]" new (1+ j)))))
  407.     (substring new 0 (1+ j))
  408.       new))
  409. )
  410.  
  411. (defun temp-minibuffer-message (m)
  412.   "A Lisp version of temp_minibuffer_message from minibuf.c."
  413.   (let ((savemax (point-max)))
  414.     (save-excursion
  415.       (goto-char (point-max))
  416.       (insert m))
  417.     (let ((inhibit-quit t))
  418.       (sit-for 2)
  419.       (delete-region savemax (point-max))
  420.       (if quit-flag
  421.       (setq quit-flag nil
  422.         unread-command-char 7))))
  423. )
  424.  
  425.  
  426.