[slime-devel] ilisp-style symbol completion patch

[xach at xach.com]

Attached is a patch that, along with completer.el from ILISP, adds
partial ILISP-style symbol completion to SLIME.

Zach

-------------- next part --------------
? completer.el
Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.110
diff -u -r1.110 slime.el
--- slime.el	25 Nov 2003 21:28:23 -0000	1.110
+++ slime.el	26 Nov 2003 22:36:30 -0000
@@ -58,6 +58,7 @@
 (require 'hideshow)
 (require 'hyperspec)
 (require 'font-lock)
+(require 'completer)
 (when (featurep 'xemacs)
   (require 'overlay))
 (eval-when (compile load eval)
@@ -2389,33 +2390,27 @@
   ;; NB: It is only the name part of the symbol that we actually want
   ;; to complete -- the package prefix, if given, is just context.
   (interactive)
-  (let* ((end (point))
+  (let* ((end (slime-symbol-end-pos))
          (beg (slime-symbol-start-pos))
          (prefix (buffer-substring-no-properties beg end))
-         (completions (slime-completions prefix))
-         (completions-alist (slime-bogus-completion-alist completions))
-         (completion (try-completion prefix completions-alist nil)))
-    (cond ((eq completion t)
-           (message "[Sole completion]")
-           (slime-complete-restore-window-configuration))
-          ((null completion)
-           (message "Can't find completion for \"%s\"" prefix)
-           (ding)
-           (slime-complete-restore-window-configuration))
-          ((not (string= prefix completion))
-           (delete-region beg end)
-           (insert-and-inherit completion)
-           (cond ((null (cdr completions))
-                  (slime-complete-restore-window-configuration))
-                 (t (slime-complete-delay-restoration))))
-          (t
-           (message "Making completion list...")
-           (let ((list (all-completions prefix completions-alist nil)))
+         (completions (slime-completions prefix)))
+    (destructuring-bind (match common-substring matches unique-p)
+        (completer prefix completions nil "-")
+      (cond ((eq unique-p t)
+             (message "[Sole completion]")
+             (delete-region beg end)
+             (insert match)
+             (slime-complete-restore-window-configuration))
+            ((null match)
+             (message "Can't find completion for \"%s\"" prefix)
+             (ding)
+             (slime-complete-restore-window-configuration))
+            (t 
              (slime-complete-maybe-save-window-configuration)
-             (with-output-to-temp-buffer "*Completions*"
-               (display-completion-list list))
-             (slime-complete-delay-restoration))
-           (message "Making completion list...done")))))
+             (completer-display-choices completions)
+             (slime-complete-delay-restoration)
+             (completer-goto match common-substring 
+                             matches unique-p "^ \t\n\('\"#.\)<>" "-"))))))
 
 (defun slime-completing-read-internal (string default-package flag)
   ;; We misuse the predicate argument to pass the default-package.
@@ -2471,6 +2466,11 @@
     (backward-sexp 1)
     (skip-syntax-forward "'")
     (point)))
+
+(defun slime-symbol-end-pos ()
+  (save-excursion
+    (skip-syntax-forward "_")
+    (min (1+ (point)) (point-max))))
 
 (defun slime-bogus-completion-alist (list)
   "Make an alist out of list.
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.65
diff -u -r1.65 swank.lisp
--- swank.lisp	24 Nov 2003 03:23:32 -0000	1.65
+++ swank.lisp	26 Nov 2003 22:36:30 -0000
@@ -473,7 +473,7 @@
                          (find-package (case-convert n))
                          *buffer-package* ))))
       (flet ((symbol-matches-p (symbol)
-               (and (string-prefix-p name (symbol-name symbol))
+               (and (compound-string-match name (symbol-name symbol))
                     (or (or internal-p (null package-name))
                         (symbol-external-p symbol package)))))
         (when package
@@ -533,6 +533,42 @@
 \(This includes the case where S1 is equal to S2.)"
   (and (<= (length s1) (length s2))
        (string-equal s1 s2 :end2 (length s1))))
+
+(defun subword-prefix-p (s1 s2 &key (start1 0) end1 (start2 0))
+  "Return true if the subsequence in S1 bounded by START1 and END1
+is found in S1 at START1."
+  (let ((end2 (min (length s2)
+                   (+ start2 (- (or end1 (length s1))
+                                start1)))))
+    (string-equal s1 s2
+                  :start1 start1 :end1 end1
+                  :start2 start2 :end2 end2)))
+
+(defun word-points (string)
+  (declare (string string))
+  (loop for pos = -1 then (position #\- string :start (1+ pos))
+        while pos
+        collect (1+ pos)))
+
+(defun compound-string-match (string1 string2)
+  "Return true if STRING1 is a prefix of STRING2, or if STRING1
+represents a pattern of prefixes and delimiters matching full strings
+and delimiters in STRING2.
+Examples:
+\(compound-string-match \"foo\" \"foobar\") => t
+\(compound-string-match \"m-v-b\" \"multiple-value-bind\") => t
+\(compound-string-match \"m-v-c\" \"multiple-value-bind\") => NIL"
+  (when (<= (length string1) (length string2))
+    (let ((s1-word-points (word-points string1))
+          (s2-word-points (word-points string2)))
+      (when (<= (length s1-word-points) (length s2-word-points))
+        (loop for (start1 end1) on s1-word-points
+              for start2 in s2-word-points
+              always (subword-prefix-p string1 string2
+                                       :start1 start1
+                                       :end1 (and end1 (1- end1))
+                                       :start2 start2))))))
+
 
 
 ;;;; Documentation