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