[slime-cvs] CVS update: slime/swank.lisp slime/slime.el
Luke Gorrie
lgorrie at common-lisp.net
Tue Jun 22 08:02:15 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv3456
Modified Files:
swank.lisp slime.el
Log Message:
Added "fuzzy completion" by Brian Downing.
Date: Tue Jun 22 01:02:15 2004
Author: lgorrie
Index: slime/swank.lisp
diff -u slime/swank.lisp:1.201 slime/swank.lisp:1.202
--- slime/swank.lisp:1.201 Mon Jun 21 23:24:48 2004
+++ slime/swank.lisp Tue Jun 22 01:02:15 2004
@@ -1611,14 +1611,16 @@
(let ((package (carefully-find-package package-name default-package-name)))
(values name package-name package internal-p))))
+(defun format-completion-result (string internal-p package-name)
+ (let ((prefix (cond (internal-p (format nil "~A::" package-name))
+ (package-name (format nil "~A:" package-name))
+ (t ""))))
+ (values (concatenate 'string prefix string)
+ (length prefix))))
+
(defun format-completion-set (strings internal-p package-name)
(mapcar (lambda (string)
- (cond (internal-p
- (format nil "~A::~A" package-name string))
- (package-name
- (format nil "~A:~A" package-name string))
- (t
- (format nil "~A" string))))
+ (format-completion-result string internal-p package-name))
(sort strings #'string<)))
(defun output-case-converter (input)
@@ -1677,6 +1679,80 @@
(nconc (mapcar #'symbol-name symbols) packs))))
(format-completion-set strings internal-p package-name))))
+(defun fuzzy-find-matching-symbols (string package external)
+ "Return a list of symbols in PACKAGE matching STRING using the
+fuzzy completion algorithm. If EXTERNAL is true, only external
+symbols are returned."
+ (let ((completions '())
+ (converter (output-case-converter string)))
+ (flet ((symbol-match (symbol)
+ (and (or (not external)
+ (symbol-external-p symbol package))
+ (compute-highest-scoring-completion
+ string (funcall converter (symbol-name symbol)) #'char=))))
+ (do-symbols (symbol package)
+ (multiple-value-bind (result score) (symbol-match symbol)
+ (when result
+ (push (list symbol score result) completions)))))
+ (remove-duplicates completions :key #'first)))
+
+(defun fuzzy-find-matching-packages (name)
+ "Return a list of package names matching NAME using the fuzzy
+completion algorithm."
+ (let ((converter (output-case-converter name)))
+ (loop for package in (list-all-packages)
+ for package-name = (concatenate 'string
+ (funcall converter
+ (package-name package))
+ ":")
+ for (result score) = (multiple-value-list
+ (compute-highest-scoring-completion
+ name package-name #'char=))
+ if result collect (list package-name score result))))
+
+(defun fuzzy-completion-set (string default-package-name &optional limit)
+ "Prepares list of completion objects, sorted by SCORE, of fuzzy
+completions of STRING in DEFAULT-PACKAGE-NAME. If LIMIT is set,
+only the top LIMIT results will be returned."
+ (declare (type simple-base-string string))
+ (multiple-value-bind (name package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (let* ((symbols (and package
+ (fuzzy-find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name))))
+ (packs (and (not package-name)
+ (fuzzy-find-matching-packages name)))
+ (converter (output-case-converter name))
+ (results
+ (sort (mapcar
+ #'(lambda (result)
+ (destructuring-bind (symbol-or-name score chunks) result
+ (multiple-value-bind (name added-length)
+ (format-completion-result
+ (funcall converter
+ (if (symbolp symbol-or-name)
+ (symbol-name symbol-or-name)
+ symbol-or-name))
+ internal-p package-name)
+ (list name score
+ (mapcar
+ #'(lambda (chunk)
+ ;; fix up chunk positions to
+ ;; account for possible added
+ ;; package identifier
+ (list (+ added-length (first chunk))
+ (second chunk)))
+ chunks)))))
+ (nconc symbols packs))
+ #'> :key #'second)))
+ (when (and limit
+ (> limit 0)
+ (< limit (length results)))
+ (setf (cdr (nthcdr (1- limit) results)) nil))
+ results)))
+
(defslimefun completions (string default-package-name)
"Return a list of completions for a symbol designator STRING.
@@ -1705,6 +1781,45 @@
#'prefix-match-p)))
(list completion-set (longest-common-prefix completion-set))))
+(defslimefun fuzzy-completions (string default-package-name &optional limit)
+ "Return an (optionally limited to LIMIT best results) list of
+fuzzy completions for a symbol designator STRING. The list will
+be sorted by score, most likely match first.
+
+The result is a list of completion objects, where a completion
+object is:
+ (COMPLETED-STRING SCORE (&rest CHUNKS))
+where a CHUNK is a description of a matched string of characters:
+ (OFFSET STRING)
+For example, the top result for completing \"mvb\" in a package
+that uses COMMON-LISP would be something like:
+ (\"multiple-value-bind\" 42.391666 ((0 \"mul\") (9 \"v\") (15 \"b\")))
+
+If STRING is package qualified the result list will also be
+qualified. If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+Which symbols are candidates for matching depends on the symbol
+designator's format. The cases are as follows:
+ FOO - Symbols accessible in the buffer package.
+ PKG:FOO - Symbols external in package PKG.
+ PKG::FOO - Symbols accessible in package PKG."
+ (fuzzy-completion-set string default-package-name limit))
+
+(defslimefun fuzzy-completion-selected (original-string completion)
+ "This function is called by Slime when a fuzzy completion is
+selected by the user. It is for future expansion to make
+testing, say, a machine learning algorithm for completion scoring
+easier.
+
+ORIGINAL-STRING is the string the user completed from, and
+COMPLETION is the completion object (see docstring for
+SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
+user selected."
+ (declare (ignore original-string completion))
+ nil)
+
(defun tokenize-symbol-designator (string)
"Parse STRING as a symbol designator.
Return three values:
@@ -1726,6 +1841,231 @@
(declare (ignore _))
(eq status :external)))
+;;; Fuzzy completion core
+
+(defparameter *fuzzy-recursion-soft-limit* 30
+ "This is a soft limit for recursion in
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
+completing a string such as \"ZZZZZZ\" with a symbol named
+\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
+find all the ways it can match.
+
+Most natural language searches and symbols do not have this
+problem -- this is only here as a safeguard.")
+
+(defun recursively-compute-most-completions
+ (short full test
+ short-index initial-full-index
+ chunks current-chunk current-chunk-pos
+ recurse-p)
+ "Recursively (if RECURSE-P is true) find /most/ possible ways
+to fuzzily map the letters in SHORT onto FULL, with TEST being a
+function to determine if two letters match.
+
+A chunk is a list of elements that have matched consecutively.
+When consecutive matches stop, it is coerced into a string,
+paired with the starting position of the chunk, and pushed onto
+CHUNKS.
+
+Whenever a letter matches, if RECURSE-P is true,
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
+one index ahead, to find other possibly higher scoring
+possibilities. If there are less than
+*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
+this call will also recurse.
+
+Once a word has been completely matched, the chunks are pushed
+onto the special variable *ALL-CHUNKS* and the function returns."
+ (declare (special *all-chunks*))
+ (flet ((short-cur ()
+ "Returns the next letter from the abbreviation, or NIL
+ if all have been used."
+ (if (= short-index (length short))
+ nil
+ (aref short short-index)))
+ (add-to-chunk (char pos)
+ "Adds the CHAR at POS in FULL to the current chunk,
+ marking the start position if it is empty."
+ (unless current-chunk
+ (setf current-chunk-pos pos))
+ (push char current-chunk))
+ (collect-chunk ()
+ "Collects the current chunk to CHUNKS and prepares for
+ a new chunk."
+ (when current-chunk
+ (push (list current-chunk-pos
+ (coerce (reverse current-chunk) 'string)) chunks)
+ (setf current-chunk nil
+ current-chunk-pos nil))))
+ ;; If there's an outstanding chunk coming in collect it. Since
+ ;; we're recursively called on skipping an input character, the
+ ;; chunk can't possibly continue on.
+ (when current-chunk (collect-chunk))
+ (do ((pos initial-full-index (1+ pos)))
+ ((= pos (length full)))
+ (let ((cur-char (aref full pos)))
+ (if (and (short-cur)
+ (funcall test cur-char (short-cur)))
+ (progn
+ (when recurse-p
+ ;; Try other possibilities, limiting insanely deep
+ ;; recursion somewhat.
+ (recursively-compute-most-completions
+ short full test short-index (1+ pos)
+ chunks current-chunk current-chunk-pos
+ (not (> (length *all-chunks*)
+ *fuzzy-recursion-soft-limit*))))
+ (incf short-index)
+ (add-to-chunk cur-char pos))
+ (collect-chunk))))
+ (collect-chunk)
+ ;; If we've exhausted the short characters we have a match.
+ (if (short-cur)
+ nil
+ (let ((rev-chunks (reverse chunks)))
+ (push rev-chunks *all-chunks*)
+ rev-chunks))))
+
+(defun compute-most-completions (short full test)
+ "Finds most possible ways to complete FULL with the letters in SHORT.
+Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
+a list of (&rest CHUNKS), where each CHUNKS is a description of
+how a completion matches."
+ (let ((*all-chunks* nil))
+ (declare (special *all-chunks*))
+ (recursively-compute-most-completions short full test 0 0 nil nil nil t)
+ *all-chunks*))
+
+(defun compute-completion (short full test)
+ "Finds the first way to complete FULL with the letters in SHORT.
+Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS non-recursively.
+Returns a list of one (&rest CHUNKS), where CHUNKS is a
+description of how the completion matched."
+ (let ((*all-chunks* nil))
+ (declare (special *all-chunks*))
+ (recursively-compute-most-completions short full test 0 0 nil nil nil nil)
+ *all-chunks*))
+
+(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
+ "Letters that are likely to be at the beginning of a symbol.
+Letters found after one of these prefixes will be scored as if
+they were at the beginning of ths symbol.")
+(defparameter *fuzzy-completion-symbol-suffixes* "*+->"
+ "Letters that are likely to be at the end of a symbol.
+Letters found before one of these suffixes will be scored as if
+they were at the end of the symbol.")
+(defparameter *fuzzy-completion-word-separators* "-/."
+ "Letters that separate different words in symbols. Letters
+after one of these symbols will be scores more highly than other
+letters.")
+
+(defun score-completion (completion short full)
+ "Scores the completion chunks COMPLETION as a completion from
+the abbreviation SHORT to the full string FULL. COMPLETION is a
+list like:
+ ((0 \"mul\") (9 \"v\") (15 \"b\"))
+Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
+would indicate that it completed as such (completed letters
+capitalized):
+ MULtiple-Value-Bind
+
+Letters are given scores based on their position in the string.
+Letters at the beginning of a string or after a prefix letter at
+the beginning of a string are scored highest. Letters after a
+word separator such as #\- are scored next highest. Letters at
+the end of a string or before a suffix letter at the end of a
+string are scored medium, and letters anywhere else are scored
+low.
+
+If a letter is directly after another matched letter, and its
+intrinsic value in that position is less than a percentage of the
+previous letter's value, it will use that percentage instead.
+
+Finally, a small scaling factor is applied to favor shorter
+matches, all other things being equal."
+ (flet ((score-chunk (chunk)
+ (let ((initial-pos (first chunk))
+ (str (second chunk)))
+ (labels ((at-beginning-p (pos)
+ (= pos 0))
+ (after-prefix-p (pos)
+ (and (= pos 1)
+ (find (aref full 0)
+ *fuzzy-completion-symbol-prefixes*)))
+ (word-separator-p (pos)
+ (find (aref full pos)
+ *fuzzy-completion-word-separators*))
+ (after-word-separator-p (pos)
+ (find (aref full (1- pos))
+ *fuzzy-completion-word-separators*))
+ (at-end-p (pos)
+ (= pos (1- (length full))))
+ (before-suffix-p (pos)
+ (and (= pos (- (length full) 2))
+ (find (aref full (1- (length full)))
+ *fuzzy-completion-symbol-suffixes*)))
+ (score-or-percentage-of-previous
+ (base-score pos chunk-pos)
+ (if (zerop chunk-pos)
+ base-score
+ (max base-score
+ (* (score-char (1- pos) (1- chunk-pos))
+ 0.85))))
+ (score-char (pos chunk-pos)
+ (score-or-percentage-of-previous
+ (cond ((at-beginning-p pos) 10)
+ ((after-prefix-p pos) 10)
+ ((word-separator-p pos) 1)
+ ((after-word-separator-p pos) 8)
+ ((at-end-p pos) 6)
+ ((before-suffix-p pos) 6)
+ (t 1))
+ pos chunk-pos)))
+ (loop for chunk-pos below (length str)
+ for pos from initial-pos
+ summing (score-char pos chunk-pos))))))
+ (let* ((chunk-scores (mapcar #'score-chunk completion))
+ (length-score
+ (/ 10 (coerce (1+ (- (length full) (length short)))
+ 'single-float))))
+ (values
+ (+ (apply #'+ chunk-scores) length-score)
+ (list (mapcar #'list chunk-scores completion) length-score)))))
+
+(defun compute-highest-scoring-completion (short full test)
+ "Finds the highest scoring way to complete the abbreviation
+SHORT onto the string FULL, using TEST as a equality function for
+letters. Returns two values: The first being the completion
+chunks of the high scorer, and the second being the score."
+ (let* ((scored-results
+ (mapcar #'(lambda (result)
+ (cons (score-completion result short full) result))
+ (compute-most-completions short full test)))
+ (winner (first (sort scored-results #'> :key #'first))))
+ (values (rest winner) (first winner))))
+
+(defun highlight-completion (completion full)
+ "Given a chunk definition COMPLETION and the string FULL,
+HIGHLIGHT-COMPLETION will create a string that demonstrates where
+the completion matched in the string. Matches will be
+capitalized, while the rest of the string will be lower-case."
+ (let ((highlit (string-downcase full)))
+ (dolist (chunk completion)
+ (setf highlit (string-upcase highlit
+ :start (first chunk)
+ :end (+ (first chunk)
+ (length (second chunk))))))
+ highlit))
+
+(defun format-fuzzy-completions (winners)
+ "Given a list of completion objects such as on returned by
+FUZZY-COMPLETIONS, format the list into user-readable output."
+ (let ((max-len
+ (loop for winner in winners maximizing (length (first winner)))))
+ (loop for (sym score result) in winners do
+ (format t "~&~VA score ~8,2F ~A"
+ max-len (highlight-completion result sym) score result))))
+
;;;;; Subword-word matching
Index: slime/slime.el
diff -u slime/slime.el:1.329 slime/slime.el:1.330
--- slime/slime.el:1.329 Mon Jun 21 22:50:47 2004
+++ slime/slime.el Tue Jun 22 01:02:15 2004
@@ -311,6 +311,7 @@
Programming aids:
\\[slime-complete-symbol] - Complete the Lisp symbol at point. (Also M-TAB.)
+\\[slime-fuzzy-complete-symbol] - Fuzzily completes text at point to a Lisp symbol.
\\[slime-macroexpand-1] - Macroexpand once.
\\[slime-macroexpand-all] - Macroexpand all.
@@ -441,6 +442,7 @@
;; Editing/navigating
("\M-\C-i" slime-complete-symbol :inferior t)
("\C-i" slime-complete-symbol :prefixed t :inferior t)
+ ("\M-i" slime-fuzzy-complete-symbol :prefixed t :inferior t)
("\M-." slime-edit-definition :inferior t :sldb t)
("\M-," slime-pop-find-definition-stack :inferior t :sldb t)
("\C-q" slime-close-parens-at-point :prefixed t :inferior t)
@@ -4039,6 +4041,337 @@
(slime-buffer-package)))))
+;;; Fuzzy completion
+
+(defvar slime-fuzzy-completion-target-buffer nil
+ "The buffer that is the target of the completion activities.")
+(defvar slime-fuzzy-completion-window-configuration nil
+ "The saved window configuration before the fuzzy completion
+buffer popped up.")
+(defvar slime-fuzzy-completion-start nil
+ "The beginning of the completion slot in the target buffer.")
+(defvar slime-fuzzy-completion-end nil
+ "The end of the completion slot in the target buffer.")
+(defvar slime-fuzzy-completion-original-text nil
+ "The original text that was in the completion slot in the
+target buffer. This is what is put back if completion is
+aborted.")
+(defvar slime-fuzzy-completion-current-text nil
+ "The text that is currently in the completion slot in the
+target buffer. If this ever doesn't match, the target buffer has
+been modified and we abort without touching it.")
+(defvar slime-fuzzy-completion-first nil
+ "The position of the first completion in the completions buffer.
+The descriptive text and headers are above this.")
+(defvar slime-fuzzy-completion-current-completion nil
+ "The current completion object. If this is the same before and
+after point moves in the completions buffer, the text is not
+replaced in the target for efficiency.")
+
+(define-derived-mode slime-fuzzy-mode
+ fundamental-mode "Fuzzy Completions"
+ "Major mode for presenting fuzzy completion results.
+
+\\<slime-fuzzy-map>
+\\{slime-fuzzy-map}"
+ (use-local-map slime-fuzzy-map))
+
+(defvar slime-fuzzy-map
+ (let* ((map (make-sparse-keymap)))
+
+ (define-key map "q" 'slime-fuzzy-completion-abort)
+ (define-key map "\r" 'slime-fuzzy-completion-select)
+
+ (define-key map "n" 'slime-fuzzy-completion-next)
+ (define-key map "\M-n" 'slime-fuzzy-completion-next)
+
+ (define-key map "p" 'slime-fuzzy-completion-prev)
+ (define-key map "\M-p" 'slime-fuzzy-completion-prev)
+
+ (define-key map "\d" 'scroll-down)
+ (define-key map " " 'scroll-up)
+
+ (define-key map [mouse-2] 'slime-fuzzy-completion-click)
+
+ map)
+ "Keymap for slime-fuzzy-mode.")
+
+(defun slime-fuzzy-completions (prefix &optional default-package)
+ "Get the list of sorted completion objects from completing
+`prefix' in `package' from the connected Lisp."
+ (let ((prefix (etypecase prefix
+ (symbol (symbol-name prefix))
+ (string prefix))))
+ (slime-eval `(swank:fuzzy-completions ,prefix
+ ,(or default-package
+ (slime-find-buffer-package)
+ (slime-buffer-package))))))
+
+(defun slime-fuzzy-completion-selected (prefix completion)
+ "Tell the connected Lisp that the user selected completion
+`completion' as the completion for `prefix'."
+ (let ((no-properties (copy-sequence prefix)))
+ (set-text-properties 0 (length no-properties) nil no-properties)
+ (slime-eval `(swank:fuzzy-completion-selected ,no-properties
+ ',completion))))
+
+(defun* slime-fuzzy-complete-symbol ()
+ "Fuzzily completes the abbreviation at point into a symbol."
+ (interactive)
+ (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
+ (return-from slime-fuzzy-complete-symbol
+ (comint-dynamic-complete-as-filename)))
+ (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
+ (beg (move-marker (make-marker) (slime-symbol-start-pos)))
+ (prefix (buffer-substring-no-properties beg end))
+ (completion-set (slime-fuzzy-completions prefix)))
+ (if (null completion-set)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-complete-restore-window-configuration))
+ (goto-char end)
+ (cond ((= (length completion-set) 1)
+ (insert-and-inherit (caar completion-set))
+ (delete-region beg end)
+ (goto-char (+ beg (length (caar completion-set))))
+ (slime-minibuffer-respecting-message "Sole completion"))
+ ;; Incomplete
+ (t
+ (slime-minibuffer-respecting-message "Complete but not unique")
+ (slime-fuzzy-completion-choices-buffer completion-set beg end)))
+ )))
+
+
+(defun get-slime-fuzzy-buffer ()
+ (get-buffer-create "*Fuzzy Completions*"))
+
+(defvar slime-fuzzy-explanation
+ "Click <mouse-2> on a completion to select it.
+In this buffer, type n and p to navigate between completions.
+Type RET to select the completion near point. Type q to abort.
+\n"
+ "The explanation that gets inserted at the beginning of the
+*Fuzzy Completions* buffer.")
+
+(defun slime-fuzzy-insert-completion-choice (completion max-length)
+ "Inserts the completion object `completion' as a formatted
+completion choice into the current buffer, and mark it with the
+proper text properties."
+ (let ((start (point))
+ (symbol (first completion))
+ (score (second completion))
+ (chunks (third completion)))
+ (insert symbol)
+ (let ((end (point)))
+ (dolist (chunk chunks)
+ (put-text-property (+ start (first chunk))
+ (+ start (first chunk)
+ (length (second chunk)))
+ 'face 'bold))
+ (put-text-property start (point) 'mouse-face 'highlight)
+ (dotimes (i (- max-length (- end start)))
+ (insert " "))
+ (insert (format " %8.2f" score))
+ (insert "\n")
+ (put-text-property start (point) 'completion completion))))
+
+(defun slime-fuzzy-completion-click (event)
+ "Handle a mouse-2 click on a completion choice as if point were
+on the completion choice and the slime-fuzzy-completion-select
+command was run."
+ (interactive "e")
+ (save-excursion
+ (with-current-buffer (window-buffer (posn-window (event-end event)))
+ (save-excursion
+ (goto-char (posn-point (event-end event)))
+ (when (get-text-property (point) 'mouse-face)
+ (slime-fuzzy-completion-insert-from-point)
+ (slime-fuzzy-completion-select))))))
+
+(defun slime-fuzzy-completion-insert (text)
+ "Inserts `text' into the target buffer in the completion slot.
+If the buffer has been modified in the meantime, abort the
+completion process. Otherwise, update all completion variables
+so that the new text is present."
+ (with-current-buffer slime-fuzzy-completion-target-buffer
+ (when (not (string-equal slime-fuzzy-completion-current
+ (buffer-substring slime-fuzzy-completion-start
+ slime-fuzzy-completion-end)))
+ (slime-fuzzy-completion-done)
+ ;; Not an error, we may be in the post-command-hook.
+ (beep)
+ (message "Target buffer has been modified!"))
+ (goto-char slime-fuzzy-completion-end)
+ (insert-and-inherit text)
+ (delete-region slime-fuzzy-completion-start slime-fuzzy-completion-end)
+ (setq slime-fuzzy-completion-end (+ slime-fuzzy-completion-start
+ (length text)))
+ (setq slime-fuzzy-completion-current text)
+ (goto-char slime-fuzzy-completion-end)))
+
+(defun slime-fuzzy-completion-choices-buffer (completions start end)
+ "Creates (if neccessary), populates, and pops up the *Fuzzy
+Completions* buffer with the completions from `completions' and
+the completion slot in the current buffer bounded by `start' and
+`end'. This saves the window configuration before popping the
+buffer so that it can possibly be restored when the user is
+done."
+ (remove-hook 'window-configuration-change-hook
+ 'slime-fuzzy-completion-window-configuration-change)
+ (setq slime-fuzzy-completion-start start)
+ (setq slime-fuzzy-completion-end end)
+ (setq slime-fuzzy-completion-original-text (buffer-substring start end))
+ (setq slime-fuzzy-completion-current slime-fuzzy-completion-original-text)
+ (setq slime-fuzzy-completion-target-buffer (current-buffer))
+ (set-buffer (get-slime-fuzzy-buffer))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (slime-fuzzy-mode)
+ (insert slime-fuzzy-explanation)
+ (let ((max-length 12))
+ (dolist (completion completions)
+ (setf max-length (max max-length (length (first completion)))))
+ (insert "Completion:")
+ (dotimes (i (- max-length 10)) (insert " "))
+ (insert "Score:\n")
+ (dotimes (i max-length) (insert "-"))
+ (insert " --------\n")
+ (setq slime-fuzzy-completion-first (point))
+ (dolist (completion completions)
+ (slime-fuzzy-insert-completion-choice completion max-length))
+ (setq buffer-read-only t))
+ (setq slime-fuzzy-completion-current-completion
+ (caar completions))
+ (slime-fuzzy-completion-insert (caar completions))
+ (goto-char slime-fuzzy-completion-first)
+ (slime-fuzzy-completion-save-window-configuration)
+ (pop-to-buffer (current-buffer))
+ (make-local-variable 'post-command-hook)
+ (add-hook 'post-command-hook
+ 'slime-fuzzy-completion-post-command-hook))
+
+(defun slime-fuzzy-completion-insert-from-point ()
+ "Inserts the completion that is under point in the completions
+buffer into the target buffer. If the completion in question had
+already been inserted, it does nothing."
+ (with-current-buffer (get-slime-fuzzy-buffer)
+ (let ((current-completion (get-text-property (point) 'completion)))
+ (when (and current-completion
+ (not (eq slime-fuzzy-completion-current-completion
+ current-completion)))
+ (slime-fuzzy-completion-insert
+ (first (get-text-property (point) 'completion)))
+ (setq slime-fuzzy-completion-current-completion
+ current-completion)))))
+
+(defun slime-fuzzy-completion-post-command-hook ()
+ "The post-command-hook for the *Fuzzy Completions* buffer.
+This makes sure the completion slot in the target buffer matches
+the completion that point is on in the completions buffer."
+ (condition-case err
+ (when slime-fuzzy-completion-target-buffer
+ (slime-fuzzy-completion-insert-from-point))
+ (error
+ ;; Because this is called on the post-command-hook, we mustn't let
+ ;; errors propagate.
+ (message "Error in slime-fuzzy-completion-post-command-hook: %S" err))))
+
+(defun slime-fuzzy-completion-next ()
+ "Moves point directly to the next completion in the completions
+buffer."
+ (interactive)
+ (goto-char
+ (next-single-char-property-change (point) 'completion)))
+
+(defun slime-fuzzy-completion-prev ()
+ "Moves point directly to the previous completion in the
+completions buffer."
+ (interactive)
+ (goto-char (previous-single-char-property-change
+ (point) 'completion
+ nil slime-fuzzy-completion-first)))
+
+(defun slime-fuzzy-completion-abort ()
+ "Aborts the completion process, setting the completions slot in
+the target buffer back to its original contents."
+ (interactive)
+ (when slime-fuzzy-completion-target-buffer
+ (slime-fuzzy-completion-insert slime-fuzzy-completion-original-text)
+ (slime-fuzzy-completion-done)))
+
+(defun slime-fuzzy-completion-select ()
+ "Selects the current completion, making sure that it is inserted
+into the target buffer. This tells the connected Lisp what completion
+was selected."
+ (interactive)
+ (when slime-fuzzy-completion-target-buffer
+ (with-current-buffer (get-slime-fuzzy-buffer)
+ (let ((completion (get-text-property (point) 'completion)))
+ (when completion
+ (slime-fuzzy-completion-insert (first completion))
+ (slime-fuzzy-completion-selected slime-fuzzy-completion-original-text
+ completion)
+ (slime-fuzzy-completion-done))))))
+
+(defun slime-fuzzy-completion-done ()
+ "Cleans up after the completion process. This removes all hooks,
+and attempts to restore the window configuration. If this fails,
+it just burys the completions buffer and leaves the window
+configuration alone."
+ (set-buffer slime-fuzzy-completion-target-buffer)
+ (remove-hook 'post-command-hook
+ 'slime-fuzzy-completion-post-command-hook)
+ (if (slime-fuzzy-completion-maybe-restore-window-configuration)
+ (bury-buffer (get-slime-fuzzy-buffer))
+ ;; We couldn't restore the windows, so just bury the
+ ;; fuzzy completions buffer and let something else fill
+ ;; it in.
+ (pop-to-buffer (get-slime-fuzzy-buffer))
+ (bury-buffer))
+ (pop-to-buffer slime-fuzzy-completion-target-buffer)
+ (goto-char slime-fuzzy-completion-end)
+ (setq slime-fuzzy-completion-target-buffer nil))
+
+(defun slime-fuzzy-completion-save-window-configuration ()
+ "Saves the current window configuration, and sets up for the
+saved configuration to be nullified if the user changes the
+window configuration further. Adding the nullification routine
+to window-configuration-change-hook is delayed so that the
+windows stabalize before we start listening on the hook."
+ (setq slime-fuzzy-completion-window-configuration
+ (current-window-configuration))
+ (setq slime-fuzzy-completion-window-configuration-change-count 0)
+ (run-with-timer
+ 0.5 nil 'slime-fuzzy-completion-window-configuration-change-add-hook))
+
+(defun slime-fuzzy-completion-maybe-restore-window-configuration ()
+ "Restores the saved window configuration if it has not been
+nullified."
+ (remove-hook 'window-configuration-change-hook
+ 'slime-fuzzy-completion-window-configuration-change)
+ (if (not slime-fuzzy-completion-window-configuration)
+ nil
+ (set-window-configuration slime-fuzzy-completion-window-configuration)
+ (setq slime-fuzzy-completion-window-configuration nil)
+ t))
+
+(defun slime-fuzzy-completion-window-configuration-change-add-hook ()
+ "Sets up slime-fuzzy-completion-window-configuration-change on
+window-configuration-change-hook."
+ (remove-hook 'post-command-hook
+ 'slime-fuzzy-completion-window-configuration-change-add-hook)
+ (add-hook 'window-configuration-change-hook
+ 'slime-fuzzy-completion-window-configuration-change))
+
+(defun slime-fuzzy-completion-window-configuration-change ()
+ "Called on window-configuration-change-hook. Since the window
+configuration was changed, we nullify our saved configuration."
+ (remove-hook 'window-configuration-change-hook
+ 'slime-fuzzy-completion-window-configuration-change)
+ (setq slime-fuzzy-completion-window-configuration nil))
+
+
;;; Interpreting Elisp symbols as CL symbols (package qualifiers)
(defun slime-cl-symbol-name (symbol)
@@ -6080,7 +6413,9 @@
(fill-paragraph nil)
(let ((start (progn (unless (and (zerop (current-column))
(eq ?\( (char-after)))
- (beginning-of-defun))
+ (if slime-repl-input-start-mark
+ (slime-repl-beginning-of-defun)
+ (beginning-of-defun)))
(point)))
(end (ignore-errors (end-of-defun) (point))))
(unless end
More information about the slime-cvs
mailing list