[slime-cvs] CVS slime/contrib
heller
heller at common-lisp.net
Thu Aug 23 12:58:52 UTC 2007
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv31985/contrib
Added Files:
ChangeLog README slime-fuzzy.el swank-fuzzy.lisp
Log Message:
Merge contrib branch.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/19 11:19:32 1.1
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 12:58:52 1.2
@@ -0,0 +1,9 @@
+2007-08-19 Helmut Eller <heller at common-lisp.net>
+
+ Moved fuzzy completion code to contrib directory.
+
+ * slime-fuzzy.el: New file.
+ (slime-fuzzy-init): New function. Load CL code on startup.
+
+ * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy
+ completion.
--- /project/slime/cvsroot/slime/contrib/README 2007/08/19 11:19:32 1.1
+++ /project/slime/cvsroot/slime/contrib/README 2007/08/23 12:58:52 1.2
@@ -0,0 +1,15 @@
+This directory contains source code which may be useful to some Slime
+users. *.el files are Emacs Lisp source and *.lisp files contain
+Common Lisp source code. If not otherwise stated in the file itself,
+the files are placed in the Public Domain.
+
+The components in this directory are more or less detached from the
+rest of Slime. They are essentially "add-ons". But Slime can also be
+used without them. The code is maintained by the respective authors.
+
+To use the packages here, you should add this directory to your Emacs
+load-path. E.g. for fuzzy completion add this to your .emacs:
+
+ (add-to-list 'load-path "<this-directory>")
+ (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy)))
+
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2007/08/19 11:19:32 1.1
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2007/08/23 12:58:52 1.2
@@ -0,0 +1,609 @@
+;;; slime-fuzzy.el --- fuzzy symbol completion
+;;
+;; Author: Brian Downing <bdowning at lavos.net> and others
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy)))
+;;
+
+
+;;; Code
+
+(defcustom slime-fuzzy-completion-in-place t
+ "When non-NIL the fuzzy symbol completion is done in place as
+opposed to moving the point to the completion buffer."
+ :group 'slime-mode
+ :type 'boolean)
+
+(defcustom slime-fuzzy-completion-limit 300
+ "Only return and present this many symbols from swank."
+ :group 'slime-mode
+ :type 'integer)
+
+(defcustom slime-fuzzy-completion-time-limit-in-msec 1500
+ "Limit the time spent (given in msec) in swank while gathering comletitions.
+\(NOTE: currently it's rounded up the nearest second)"
+ :group 'slime-mode
+ :type 'integer)
+
+(defvar slime-fuzzy-target-buffer nil
+ "The buffer that is the target of the completion activities.")
+(defvar slime-fuzzy-saved-window-configuration nil
+ "The saved window configuration before the fuzzy completion
+buffer popped up.")
+(defvar slime-fuzzy-start nil
+ "The beginning of the completion slot in the target buffer.
+This is a non-advancing marker.")
+(defvar slime-fuzzy-end nil
+ "The end of the completion slot in the target buffer.
+This is an advancing marker.")
+(defvar slime-fuzzy-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-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-first nil
+ "The position of the first completion in the completions buffer.
+The descriptive text and headers are above this.")
+(defvar slime-fuzzy-last nil
+ "The position of the last completion in the completions buffer.
+If the time limit has exhausted during generation possible completion
+choices inside SWANK, an indication is printed below this.")
+(defvar slime-fuzzy-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.")
+(defvar slime-fuzzy-current-completion-overlay nil
+ "The overlay representing the current completion in the completion
+buffer. This is used to hightlight the text.")
+
+;;;;;;; slime-target-buffer-fuzzy-completions-mode
+;; NOTE: this mode has to be able to override key mappings in slime-mode
+
+;; FIXME: clean this up
+
+(defun mimic-key-bindings (from-keymap to-keymap bindings-or-operation operation)
+ "Iterate on BINDINGS-OR-OPERATION. If an element is a symbol then
+try to look it up (as an operation) in FROM-KEYMAP. Non symbols are taken
+as default key bindings when none to be mimiced was found in FROM-KEYMAP.
+Set the resulting list of keys in TO-KEYMAP to OPERATION."
+ (let ((mimic-keys nil)
+ (direct-keys nil))
+ (dolist (key-or-operation bindings-or-operation)
+ (if (symbolp key-or-operation)
+ (setf mimic-keys (append mimic-keys (where-is-internal key-or-operation from-keymap nil t)))
+ (push key-or-operation direct-keys)))
+ (dolist (key (or mimic-keys direct-keys))
+ (define-key to-keymap key operation))))
+
+(defvar slime-target-buffer-fuzzy-completions-map
+ (let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select-or-update-completions)
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
+ (remap (list 'isearch-forward (kbd "C-s"))
+ (lambda ()
+ (interactive)
+ (select-window (get-buffer-window (slime-get-fuzzy-buffer)))
+ (call-interactively 'isearch-forward)))
+
+ ;; some unconditional direct bindings
+ (dolist (key (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]"))
+ (define-key map key 'slime-fuzzy-select-and-process-event-in-target-buffer)))
+ map
+ )
+ "Keymap for slime-target-buffer-fuzzy-completions-mode. This will override the key
+bindings in the target buffer temporarily during completion.")
+
+;; Make sure slime-fuzzy-target-buffer-completions-mode's map is
+;; before everything else.
+(setf minor-mode-map-alist
+ (stable-sort minor-mode-map-alist
+ (lambda (a b)
+ (eq a 'slime-fuzzy-target-buffer-completions-mode))
+ :key #'car))
+
+
+(define-minor-mode slime-fuzzy-target-buffer-completions-mode
+ "This minor mode is intented to override key bindings during fuzzy
+completions in the target buffer. Most of the bindings will do an implicit select
+in the completion window and let the keypress be processed in the target buffer."
+ nil
+ nil
+ slime-target-buffer-fuzzy-completions-map)
+
+(add-to-list 'minor-mode-alist
+ '(slime-fuzzy-target-buffer-completions-mode
+ " Fuzzy Target Buffer Completions"))
+
+(define-derived-mode slime-fuzzy-completions-mode
+ fundamental-mode "Fuzzy Completions"
+ "Major mode for presenting fuzzy completion results.
+
+When you run `slime-fuzzy-complete-symbol', the symbol token at
+point is completed using the Fuzzy Completion algorithm; this
+means that the token is taken as a sequence of characters and all
+the various possibilities that this sequence could meaningfully
+represent are offered as selectable choices, sorted by how well
+they deem to be a match for the token. (For instance, the first
+choice of completing on \"mvb\" would be \"multiple-value-bind\".)
+
+Therefore, a new buffer (*Fuzzy Completions*) will pop up that
+contains the different completion choices. Simultaneously, a
+special minor-mode will be temporarily enabled in the original
+buffer where you initiated fuzzy completion (also called the
+``target buffer'') in order to navigate through the *Fuzzy
+Completions* buffer without leaving.
+
+With focus in *Fuzzy Completions*:
+ Type `n' and `p' (`UP', `DOWN') to navigate between completions.
+ Type `RET' or `TAB' to select the completion near point.
+ Type `q' to abort.
+
+With focus in the target buffer:
+ Type `UP' and `DOWN' to navigate between completions.
+ Type a character that does not constitute a symbol name
+ to insert the current choice and then that character (`(', `)',
+ `SPACE', `RET'.) Use `TAB' to simply insert the current choice.
+ Use C-g to abort.
+
+Alternatively, you can click <mouse-2> on a completion to select it.
+
+
+Complete listing of keybindings within the target buffer:
+
+\\<slime-target-buffer-fuzzy-completions-map>\
+\\{slime-target-buffer-fuzzy-completions-map}
+
+Complete listing of keybindings with *Fuzzy Completions*:
+
+\\<slime-fuzzy-completions-map>\
+\\{slime-fuzzy-completions-map}"
+ (use-local-map slime-fuzzy-completions-map))
+
+(defvar slime-fuzzy-completions-map
+ (let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+ (define-key map "q" 'slime-fuzzy-abort)
+
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
+
+ (define-key map "n" 'slime-fuzzy-next)
+ (define-key map "\M-n" 'slime-fuzzy-next)
+
+ (define-key map "p" 'slime-fuzzy-prev)
+ (define-key map "\M-p" 'slime-fuzzy-prev)
+
+ (define-key map "\d" 'scroll-down)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select)
+
+ (define-key map (kbd "<mouse-2>") 'slime-fuzzy-select/mouse))
+
+ (define-key map (kbd "RET") 'slime-fuzzy-select)
+ (define-key map (kbd "<SPC>") 'slime-fuzzy-select)
+
+ map)
+ "Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
+
+(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-current-package))
+ :limit ,slime-fuzzy-completion-limit
+ :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec))))
+
+(defun slime-fuzzy-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-indent-and-complete-symbol ()
+ "Indent the current line and perform fuzzy symbol completion. First
+indent the line. If indenting doesn't move point, complete the
+symbol. If there's no symbol at the point, show the arglist for the
+most recently enclosed macro or function."
+ (interactive)
+ (let ((pos (point)))
+ (unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
+ (lisp-indent-line))
+ (when (= pos (point))
+ (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+ (slime-fuzzy-complete-symbol))
+ ((memq (char-before) '(?\t ?\ ))
+ (slime-echo-arglist))))))
+
+(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
+ (if slime-when-complete-filename-expand
+ (comint-replace-by-expanded-filename)
+ (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)))
+ (destructuring-bind (completion-set interrupted-p)
+ (slime-fuzzy-completions prefix)
+ (if (null completion-set)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-fuzzy-done))
+ (goto-char end)
+ (cond ((slime-length= completion-set 1)
+ (insert-and-inherit (caar completion-set)) ; insert completed string
+ (delete-region beg end)
+ (goto-char (+ beg (length (caar completion-set))))
+ (slime-minibuffer-respecting-message "Sole completion")
+ (slime-fuzzy-done))
+ ;; Incomplete
+ (t
+ (slime-minibuffer-respecting-message "Complete but not unique")
+ (slime-fuzzy-choices-buffer completion-set interrupted-p beg end)))))))
+
+
+(defun slime-get-fuzzy-buffer ()
+ (get-buffer-create "*Fuzzy Completions*"))
+
+(defvar slime-fuzzy-explanation
+ "For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
+
+Flags: boundp fboundp generic-function class macro special-operator package
+\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-name (first completion))
+ (score (second completion))
+ (chunks (third completion))
+ (flags (fourth completion)))
+ (insert symbol-name)
+ (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 " %s%s%s%s%s%s%s %8.2f"
+ (if (member :boundp flags) "b" "-")
+ (if (member :fboundp flags) "f" "-")
+ (if (member :generic-function flags) "g" "-")
+ (if (member :class flags) "c" "-")
+ (if (member :macro flags) "m" "-")
+ (if (member :special-operator flags) "s" "-")
+ (if (member :package flags) "p" "-")
+ score))
+ (insert "\n")
+ (put-text-property start (point) 'completion completion))))
+
+(defun slime-fuzzy-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-target-buffer
+ (cond
+ ((not (string-equal slime-fuzzy-text
+ (buffer-substring slime-fuzzy-start
+ slime-fuzzy-end)))
+ (slime-fuzzy-done)
+ (beep)
+ (message "Target buffer has been modified!"))
+ (t
+ (goto-char slime-fuzzy-start)
+ (delete-region slime-fuzzy-start slime-fuzzy-end)
+ (insert-and-inherit text)
+ (setq slime-fuzzy-text text)
+ (goto-char slime-fuzzy-end)))))
+
+(defun slime-fuzzy-choices-buffer (completions interrupted-p 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."
+ (let ((new-completion-buffer (not slime-fuzzy-target-buffer)))
+ (when new-completion-buffer
+ (slime-fuzzy-save-window-configuration))
+ (slime-fuzzy-enable-target-buffer-completions-mode)
+ (setq slime-fuzzy-target-buffer (current-buffer))
+ (setq slime-fuzzy-start (move-marker (make-marker) start))
+ (setq slime-fuzzy-end (move-marker (make-marker) end))
+ (set-marker-insertion-type slime-fuzzy-end t)
+ (setq slime-fuzzy-original-text (buffer-substring start end))
+ (setq slime-fuzzy-text slime-fuzzy-original-text)
+ (slime-fuzzy-fill-completions-buffer completions interrupted-p)
+ (pop-to-buffer (slime-get-fuzzy-buffer))
+ (when new-completion-buffer
+ (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort)
+ (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
+ (when slime-fuzzy-completion-in-place
+ ;; switch back to the original buffer
+ (switch-to-buffer-other-window slime-fuzzy-target-buffer))))
+
+(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
+ "Erases and fills the completion buffer with the given completions."
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (slime-fuzzy-completions-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 " "))
+ ;; Flags: Score:
+ ;; ... ------- --------
+ ;; bfgcmsp
+ (insert "Flags: Score:\n")
+ (dotimes (i max-length) (insert "-"))
+ (insert " ------- --------\n")
+ (setq slime-fuzzy-first (point))
+
+ (dolist (completion completions)
+ (setq slime-fuzzy-last (point)) ; will eventually become the last entry
+ (slime-fuzzy-insert-completion-choice completion max-length))
+
+ (when interrupted-p
+ (insert "...\n")
+ (insert "[Interrupted: time limit exhausted]"))
+
+ (setq buffer-read-only t))
+ (setq slime-fuzzy-current-completion
+ (caar completions))
[212 lines skipped]
--- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/19 11:19:32 1.1
+++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp 2007/08/23 12:58:52 1.2
@@ -0,0 +1,563 @@
+;;; swank-fuzzy.lisp --- fuzzy symbol completion
+;;
+;; Author: Brian Downing <bdowning at lavos.net> and others
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+;;; For nomenclature of the fuzzy completion section, please read
+;;; through the following docstring.
+
+(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
+"Returns a list of two values:
+
+ 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.
+
+ A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
+ been exhausted during computation. If that parameter's value is
+ NIL or 0, no time limit is assumed.
+
+The main result is a list of completion objects, where a completion
+object is:
+
+ (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
+
+where a CHUNK is a description of a matched substring:
+
+ (OFFSET SUBSTRING)
+
+and FLAGS is a list of keywords describing properties of the
+symbol (see CLASSIFY-SYMBOL).
+
+E.g., completing \"mvb\" in a package that uses COMMON-LISP would
+return something like:
+
+ ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
+ (:FBOUNDP :MACRO))
+ ...)
+
+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."
+ ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
+ ;; to denote an infinite time limit. Internally, we only use NIL for
+ ;; that purpose, to be able to distinguish between "no time limit
+ ;; alltogether" and "current time limit already exhausted." So we've
+ ;; got to canonicalize its value at first:
+ (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec)))
+ (time-limit (if no-time-limit-p nil time-limit-in-msec)))
+ (multiple-value-bind (completion-set interrupted-p)
+ (fuzzy-completion-set string default-package-name :limit limit
+ :time-limit-in-msec time-limit)
+ ;; We may send this as elisp [] arrays to spare a coerce here,
+ ;; but then the network serialization were slower by handling arrays.
+ ;; Instead we limit the number of completions that is transferred
+ ;; (the limit is set from Emacs.)
+ (list (coerce completion-set 'list) interrupted-p))))
+
+
+;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
+;;; object that will be sent back to Emacs, as described above.
+
+(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
+ (:predicate fuzzy-matching-p)
+ (:constructor %make-fuzzy-matching))
+ symbol ; The symbol that has been found to match.
+ score ; The higher the better symbol is a match.
+ package-chunks ; Chunks pertaining to the package identifier of the symbol.
+ symbol-chunks) ; Chunks pertaining to the symbol's name.
+
+(defun make-fuzzy-matching (symbol score package-chunks symbol-chunks)
+ (declare (inline %make-fuzzy-matching))
+ (%make-fuzzy-matching :symbol symbol :score score
+ :package-chunks package-chunks
+ :symbol-chunks symbol-chunks))
+
+
+(defun fuzzy-convert-matching-for-emacs (fuzzy-matching converter
+ internal-p package-name)
+ "Converts a result from the fuzzy completion core into
+something that emacs is expecting. Converts symbols to strings,
+fixes case issues, and adds information describing if the symbol
+is :bound, :fbound, a :class, a :macro, a :generic-function,
+a :special-operator, or a :package."
+ (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching
+ (multiple-value-bind (name added-length)
+ (format-completion-result
+ (funcall (or converter #'identity) (symbol-name symbol))
+ internal-p package-name)
+ (list name
+ score
+ (append package-chunks
+ (mapcar #'(lambda (chunk)
+ ;; Fix up chunk positions to account for possible
+ ;; added package identifier.
+ (let ((offset (first chunk)) (string (second chunk)))
+ (list (+ added-length offset) string)))
+ symbol-chunks))
+ (classify-symbol symbol)))))
+
+(defun classify-symbol (symbol)
+ "Returns a list of classifiers that classify SYMBOL according
+to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
+special variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO,
+:SPECIAL-OPERATOR, and/or :PACKAGE"
+ (check-type symbol symbol)
+ (let (result)
+ (when (boundp symbol) (push :boundp result))
+ (when (fboundp symbol) (push :fboundp result))
+ (when (find-class symbol nil) (push :class result))
+ (when (macro-function symbol) (push :macro result))
+ (when (special-operator-p symbol) (push :special-operator result))
+ (when (find-package symbol) (push :package result))
+ (when (typep (ignore-errors (fdefinition symbol))
+ 'generic-function)
+ (push :generic-function result))
+ result))
+
+(defun symbol-classification->string (flags)
+ (format nil "~A~A~A~A~A~A~A"
+ (if (member :boundp flags) "b" "-")
+ (if (member :fboundp flags) "f" "-")
+ (if (member :generic-function flags) "g" "-")
+ (if (member :class flags) "c" "-")
+ (if (member :macro flags) "m" "-")
+ (if (member :special-operator flags) "s" "-")
+ (if (member :package flags) "p" "-")))
+
+
+(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
+ "Returns two values: an array of completion objects, sorted by
+their score, that is how well they are a match for STRING
+according to the fuzzy completion algorithm. If LIMIT is set,
+only the top LIMIT results will be returned. Additionally, a flag
+is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
+exhausted."
+ (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
+ (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum))))
+ (multiple-value-bind (completion-set interrupted-p)
+ (fuzzy-create-completion-set string default-package-name
+ time-limit-in-msec)
+ (when (and limit
+ (> limit 0)
+ (< limit (length completion-set)))
+ (if (array-has-fill-pointer-p completion-set)
+ (setf (fill-pointer completion-set) limit)
+ (setf completion-set (make-array limit :displaced-to completion-set))))
+ (values completion-set interrupted-p)))
+
+
+(defun fuzzy-create-completion-set (string default-package-name time-limit-in-msec)
+ "Does all the hard work for FUZZY-COMPLETION-SET. If
+TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
+ (multiple-value-bind (parsed-name parsed-package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (flet ((convert (matchings package-name &optional converter)
+ ;; Converts MATCHINGS to completion objects for Emacs.
+ ;; PACKAGE-NAME is the package identifier that's used as prefix
+ ;; during formatting. If NIL, the identifier is omitted.
+ (map-into matchings
+ #'(lambda (m)
+ (fuzzy-convert-matching-for-emacs m converter
+ internal-p
+ package-name))
+ matchings))
+ (fix-up (matchings parent-package-matching)
+ ;; The components of each matching in MATCHINGS have been computed
+ ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
+ (let* ((p parent-package-matching)
+ (p.score (fuzzy-matching.score p))
+ (p.chunks (fuzzy-matching.package-chunks p)))
+ (map-into matchings
+ #'(lambda (m)
+ (let ((m.score (fuzzy-matching.score m)))
+ (setf (fuzzy-matching.package-chunks m) p.chunks)
+ (setf (fuzzy-matching.score m)
+ (if (string= parsed-name "")
+ ;; (Make package matchings be sorted before all the
+ ;; relative symbol matchings while preserving over
+ ;; all orderness.)
+ (/ p.score 100)
+ (+ p.score m.score)))
+ m))
+ matchings)))
+ (find-symbols (designator package time-limit)
+ (fuzzy-find-matching-symbols designator package
+ :time-limit-in-msec time-limit
+ :external-only (not internal-p)))
+ (find-packages (designator time-limit)
+ (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit)))
+ (let ((symbol-normalizer (completion-output-symbol-converter string))
+ (package-normalizer #'(lambda (package-name)
+ (let ((converter (completion-output-package-converter string)))
+ ;; Present packages with a trailing colon for maximum convenience!
+ (concatenate 'string (funcall converter package-name) ":"))))
+ (time-limit time-limit-in-msec) (symbols) (packages) (results))
+ (cond ((not parsed-package-name) ; E.g. STRING = "asd"
+ ;; We don't know if user is searching for a package or a symbol
+ ;; within his current package. So we try to find either.
+ (setf (values packages time-limit) (find-packages parsed-name time-limit))
+ (setf (values symbols time-limit) (find-symbols parsed-name package time-limit))
+ (setf symbols (convert symbols nil symbol-normalizer))
+ (setf packages (convert packages nil package-normalizer)))
+ ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
+ (setf (values symbols time-limit) (find-symbols parsed-name package time-limit))
+ (setf symbols (convert symbols "" symbol-normalizer)))
+ (t ; E.g. STRING = "asd:" or "asd:foo"
+ ;; Find fuzzy matchings of the denoted package identifier part.
+ ;; After that, find matchings for the denoted symbol identifier
+ ;; relative to all the packages found.
+ (multiple-value-bind (found-packages rest-time-limit)
+ (find-packages parsed-package-name time-limit-in-msec)
+ (loop
+ for package-matching across found-packages
+ for package-sym = (fuzzy-matching.symbol package-matching)
+ for package-name = (funcall symbol-normalizer (symbol-name package-sym))
+ for package = (find-package package-sym)
+ while (or (not time-limit) (> rest-time-limit 0)) do
+ (multiple-value-bind (matchings remaining-time)
+ (find-symbols parsed-name package rest-time-limit)
+ (setf matchings (fix-up matchings package-matching))
+ (setf matchings (convert matchings package-name symbol-normalizer))
+ (setf symbols (concatenate 'vector symbols matchings))
+ (setf rest-time-limit remaining-time))
+ finally ; CONVERT is destructive. So we have to do this at last.
+ (setf time-limit rest-time-limit)
+ (setf packages (when (string= parsed-name "")
+ (convert found-packages nil package-normalizer)))))))
+ ;; Sort alphabetically before sorting by score. (Especially useful when
+ ;; PARSED-NAME is empty, and all possible completions are to be returned.)
+ (setf results (concatenate 'vector symbols packages))
+ (setf results (sort results #'string< :key #'first)) ; SORT + #'STRING-LESSP
+ (setf results (stable-sort results #'> :key #'second)); conses on at least SBCL 0.9.18.
+ (values results (and time-limit (<= time-limit 0)))))))
+
+
+(defun get-real-time-in-msecs ()
+ (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
+ (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value!
+
+
+(defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)
+ "Returns two values: a vector of fuzzy matchings for matching
+symbols in PACKAGE, using the fuzzy completion algorithm; the
+remaining time limit.
+
+If EXTERNAL-ONLY is true, only external symbols are considered. A
+TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
+negative, perform a NOP."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (count 0))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
+
+ (flet ((recompute-remaining-time (old-remaining-time)
+ (cond ((not time-limit-p)
+ (values nil nil)) ; propagate NIL back as infinite time limit.
+ ((> count 0) ; ease up on getting internal time like crazy.
+ (setf count (mod (1+ count) 128))
+ (values nil old-remaining-time))
+ (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))
+ (remaining (- time-limit elapsed-time)))
+ (values (<= remaining 0) remaining)))))
+ (perform-fuzzy-match (string symbol-name)
+ (let* ((converter (completion-output-symbol-converter string))
+ (converted-symbol-name (funcall converter symbol-name)))
+ (compute-highest-scoring-completion string converted-symbol-name))))
+ (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+ (rest-time-limit time-limit))
+ (block loop
+ (do-symbols* (symbol package)
+ (multiple-value-bind (exhausted? remaining-time)
+ (recompute-remaining-time rest-time-limit)
+ (setf rest-time-limit remaining-time)
+ (cond (exhausted? (return-from loop))
+ ((or (not external-only) (symbol-external-p symbol package))
+ (if (string= "" string) ; "" matchs always
+ (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '())
+ completions)
+ (multiple-value-bind (match-result score)
+ (perform-fuzzy-match string (symbol-name symbol))
+ (when match-result
+ (vector-push-extend
+ (make-fuzzy-matching symbol score '() match-result)
+ completions)))))))))
+ (values completions rest-time-limit)))))
+
+
+(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
+ "Returns a vector of fuzzy matchings for each package that is
+similiar to NAME, and the remaining time limit.
+Cf. FUZZY-FIND-MATCHING-SYMBOLS."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (converter (completion-output-package-converter name))
+ (completions (make-array 32 :adjustable t :fill-pointer 0)))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type function converter))
+ (if (and time-limit-p (<= time-limit 0))
+ (values #() time-limit)
+ (loop for package-name in (mapcan #'package-names (list-all-packages))
+ for converted-name = (funcall converter package-name)
+ for package-symbol = (or (find-symbol package-name)
+ (make-symbol package-name)) ; no INTERN
+ do (multiple-value-bind (result score)
+ (compute-highest-scoring-completion name converted-name)
+ (when result
+ (vector-push-extend (make-fuzzy-matching package-symbol score result '())
+ completions)))
+ finally
+ (return
+ (values completions
+ (and time-limit-p
+ (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)))
+ (- time-limit elapsed-time)))))))))
+
+
+(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)
+
+
+;;;;; 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.")
+(declaim (fixnum *fuzzy-recursion-soft-limit*))
+
+(defun compute-highest-scoring-completion (short full)
+ "Finds the highest scoring way to complete the abbreviation
+SHORT onto the string FULL, using CHAR= as a equality function for
+letters. Returns two values: The first being the completion
+chunks of the highest 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)))
+ (winner (first (sort scored-results #'> :key #'first))))
+ (values (rest winner) (first winner))))
+
+(defun compute-most-completions (short full)
+ "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 0 0 nil nil nil t)
+ *all-chunks*))
+
+(defun recursively-compute-most-completions
+ (short full
+ 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, using CHAR= 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,
[167 lines skipped]
More information about the slime-cvs
mailing list