branch: elpa/slime
commit 7e891a250e92847e49736530a3f0a319812d8ac9
Author: Stas Boukarev <stass...@gmail.com>
Commit: Stas Boukarev <stass...@gmail.com>
swan-c-p-c: add symbol descriptions.
---
contrib/slime-c-p-c.el | 34 ++++++++++++++++++++++++++++++----
contrib/slime-fuzzy.el | 25 +++----------------------
contrib/swank-arglists.lisp | 3 +--
contrib/swank-c-p-c.lisp | 44 +++++++++++++++++---------------------------
contrib/swank-fuzzy.lisp | 17 ++++++++++-------
contrib/swank-util.lisp | 22 ----------------------
slime-tests.el | 2 +-
slime.el | 12 +++++-------
swank.lisp | 43 ++++++++++++++++++++++++++++++++++++++-----
9 files changed, 105 insertions(+), 97 deletions(-)
diff --git a/contrib/slime-c-p-c.el b/contrib/slime-c-p-c.el
index 8f0cd1dd21b..744b47bdddd 100644
--- a/contrib/slime-c-p-c.el
+++ b/contrib/slime-c-p-c.el
@@ -55,13 +55,39 @@
(defun slime-c-p-c-completion-at-point ()
(slime-complete-symbol*))
+(defun slime-format-completions (completions)
+ (list
+ (cl-loop for (symbol-name classification-string symbol) in completions
+ collect (propertize symbol-name
+ 'slime-kind classification-string
+ 'slime-symbol symbol))
+ :company-kind (lambda (x)
+ (let ((prop (get-text-property 0 'slime-kind x)))
+ (when prop
+ (cl-loop for (char kind) in '((?g method)
+ (?f function)
+ (?b variable)
+ (?c class)
+ (?t class)
+ (?p module))
+ when (cl-find char prop)
+ return kind))))
+ :company-docsig (lambda (x)
+ (let ((sym (get-text-property 0 'slime-symbol x)))
+ (when sym
+ (slime-eval `(swank:describe-symbol ,sym)))))
+ :annotation-function
+ (lambda (x)
+ (let ((kind (get-text-property 0 'slime-kind x)))
+ (when kind
+ (concat " " kind))))))
+
(defun slime-expand-abbreviations-and-complete ()
(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-result (slime-contextual-completions beg end))
- (completion-set (cl-first completion-result)))
- (list beg end completion-set)))
+ (prefix (buffer-substring-no-properties beg end)))
+ (cl-list* beg end
+ (slime-format-completions (slime-contextual-completions beg
end)))))
(cl-defun slime-contextual-completions (beg end)
"Return a list of completions of the token from BEG to END in the
diff --git a/contrib/slime-fuzzy.el b/contrib/slime-fuzzy.el
index 1f3d35fb901..97eda3c8deb 100644
--- a/contrib/slime-fuzzy.el
+++ b/contrib/slime-fuzzy.el
@@ -273,27 +273,8 @@ most recently enclosed macro or function."
(cl-destructuring-bind (completion-set interrupted-p)
(slime-fuzzy-completions prefix)
(if slime-fuzzy-default-completion-ui
- (list beg end
- (cl-loop for (symbol-name chunks
classification-string) in completion-set
- collect (propertize
symbol-name
-
'slime-fuzzy-kind
-
classification-string))
- :company-kind (lambda (x)
- (let ((prop
(get-text-property 0 'slime-fuzzy-kind x)))
- (when prop
- (cl-loop for
(char kind) in '((?g method)
-
(?f function)
-
(?b variable)
-
(?c class)
-
(?t class)
-
(?p module))
- when
(cl-find char prop)
- return
kind))))
- :annotation-function
- (lambda (x)
- (let ((kind (get-text-property 0
'slime-fuzzy-kind x)))
- (when kind
- (concat " " kind)))))
+ (cl-list* beg end
+ (slime-format-completions
completion-set))
(if (null completion-set)
(progn
(slime-minibuffer-respecting-message
"Can't find completion for
\"%s\"" prefix)
@@ -328,7 +309,7 @@ Flags: boundp fboundp generic-function class macro
special-operator package
"Inserts the completion object `completion' as a formatted
completion choice into the current buffer, and mark it with the
proper text properties."
- (cl-destructuring-bind (symbol-name chunks classification-string)
+ (cl-destructuring-bind (symbol-name classification-string chunks)
completion
(let ((start (point))
(end))
diff --git a/contrib/swank-arglists.lisp b/contrib/swank-arglists.lisp
index 83ba6c31123..b178c0811a9 100644
--- a/contrib/swank-arglists.lisp
+++ b/contrib/swank-arglists.lisp
@@ -1226,8 +1226,7 @@ to the context provided by RAW-FORM."
(mapcar #'symbol-name matching-keywords)))
(completion-set
(format-completion-set strings nil "")))
- (list completion-set
- (longest-compound-prefix completion-set)))))))
+ completion-set)))))
(defparameter +cursor-marker+ '%cursor-marker%)
diff --git a/contrib/swank-c-p-c.lisp b/contrib/swank-c-p-c.lisp
index 6a766fbdc71..48e16c9b2e1 100644
--- a/contrib/swank-c-p-c.lisp
+++ b/contrib/swank-c-p-c.lisp
@@ -55,28 +55,31 @@ format. The cases are as follows:
(completion-set
(format-completion-set (nconc symbol-set package-set)
internal-p package-name)))
- (when completion-set
- (list completion-set (longest-compound-prefix completion-set))))))
+ completion-set)))
;;;;; Find completion set
(defun symbol-completion-set (name package-name package internal-p matchp)
"Return the set of completion-candidates as strings."
- (mapcar (completion-output-symbol-converter name)
- (and package
- (mapcar #'symbol-name
- (find-matching-symbols name
- package
- (and (not internal-p)
- package-name)
- matchp)))))
+ (when package
+ (let ((converter (completion-output-symbol-converter name)))
+ (mapcar (lambda (s)
+ (cons (funcall converter (symbol-name s))
+ s))
+ (find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name)
+ matchp)))))
(defun package-completion-set (name package-name package internal-p matchp)
(declare (ignore package internal-p))
- (mapcar (completion-output-package-converter name)
- (and (not package-name)
- (find-matching-packages name matchp))))
+ (unless package-name
+ (let ((converter (completion-output-package-converter name)))
+ (mapcar (lambda (c)
+ (cons (funcall converter c) "-------p-"))
+ (find-matching-packages name matchp)))))
(defun find-matching-symbols (string package external test)
"Return a list of symbols in PACKAGE matching STRING.
@@ -250,19 +253,6 @@ DELIMITER may be a character, or a list of characters."
;;;;; Extending the input string by completion
-(defun longest-compound-prefix (completions &optional (delimiter #\-))
- "Return the longest compound _prefix_ for all COMPLETIONS."
- (flet ((tokenizer (string) (tokenize-completion string delimiter)))
- (untokenize-completion
- (loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
- if (notevery #'string= token-list (rest token-list))
- ;; Note that we possibly collect the "" here as well, so that
- ;; UNTOKENIZE-COMPLETION will append a delimiter for us.
- collect (longest-common-prefix token-list)
- and do (loop-finish)
- else collect (first token-list))
- delimiter)))
-
(defun tokenize-completion (string delimiter)
"Return all substrings of STRING delimited by DELIMITER."
(loop with end
@@ -293,6 +283,6 @@ For example:
(let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
(completion-set (character-completion-set prefix matcher))
(completions (sort completion-set #'string<)))
- (list completions (longest-compound-prefix completions #\_))))
+ completions))
(provide :swank-c-p-c)
diff --git a/contrib/swank-fuzzy.lisp b/contrib/swank-fuzzy.lisp
index 0352aabada9..2c6c184a391 100644
--- a/contrib/swank-fuzzy.lisp
+++ b/contrib/swank-fuzzy.lisp
@@ -154,6 +154,10 @@ special-operator, or a package."
(multiple-value-bind (name added-length)
(fuzzy-format-matching fuzzy-matching user-input-string)
(list name
+ (if symbol-p
+ (symbol-classification-string symbol)
+ "-------p-")
+ (and symbol-p (write-to-string symbol :readably nil))
(append package-chunks
(mapcar (lambda (chunk)
;; Fix up chunk positions to account for possible
@@ -161,10 +165,7 @@ special-operator, or a package."
(let ((offset (first chunk))
(string (second chunk)))
(list (+ added-length offset) string)))
- symbol-chunks))
- (if symbol-p
- (symbol-classification-string symbol)
- "-------p")))))
+ symbol-chunks))))))
(defun fuzzy-completion-set (string default-package-name
&key limit time-limit-in-msec)
@@ -185,9 +186,11 @@ exhausted."
(if (array-has-fill-pointer-p matchings)
(setf (fill-pointer matchings) limit)
(setf matchings (make-array limit :displaced-to matchings))))
- (map-into matchings #'(lambda (m)
- (fuzzy-convert-matching-for-emacs m string))
- matchings)
+ (with-standard-io-syntax
+ (let ((*package* (find-package :keyword)))
+ (map-into matchings #'(lambda (m)
+ (fuzzy-convert-matching-for-emacs m string))
+ matchings)))
(values matchings interrupted-p)))
diff --git a/contrib/swank-util.lisp b/contrib/swank-util.lisp
index ff49abfe493..2a246762748 100644
--- a/contrib/swank-util.lisp
+++ b/contrib/swank-util.lisp
@@ -39,26 +39,4 @@ keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
(push :generic-function result))
result)))
-(defun symbol-classification-string (symbol)
- "Return a string in the form -f-c---- where each letter stands for
-boundp fboundp generic-function class macro special-operator package accessor"
- (let ((letters "bfgctmspa")
- (result (copy-seq "---------")))
- (flet ((flip (letter)
- (setf (char result (position letter letters))
- letter)))
- (when (boundp symbol) (flip #\b))
- (when (fboundp symbol)
- (flip #\f)
- (when (typep (ignore-errors (fdefinition symbol))
- 'generic-function)
- (flip #\g)))
- (when (type-specifier-p symbol) (flip #\t))
- (when (find-class symbol nil) (flip #\c) )
- (when (macro-function symbol) (flip #\m))
- (when (special-operator-p symbol) (flip #\s))
- (when (find-package symbol) (flip #\p))
- (when (structure-accessor-p symbol) (flip #\a))
- result)))
-
(provide :swank-util)
diff --git a/slime-tests.el b/slime-tests.el
index 438f5419975..3e3d36a4eb3 100644
--- a/slime-tests.el
+++ b/slime-tests.el
@@ -611,7 +611,7 @@ confronted with nasty #.-fu."
"swank::compile-file-output"
"swank::compile-file-pathname"))
("cl:m-v-l" ()))
- (let ((completions (slime-simple-completions prefix)))
+ (let ((completions (mapcar #'car (slime-simple-completions prefix))))
(slime-test-expect "Completion set" expected-completions completions)))
(def-slime-test read-from-minibuffer
diff --git a/slime.el b/slime.el
index 9730fa3650f..164cae6c2b6 100644
--- a/slime.el
+++ b/slime.el
@@ -3636,7 +3636,7 @@ more than one space."
Perform completion similar to `elisp-completion-at-point'."
(let* ((end (point))
(beg (slime-symbol-start-pos)))
- (list beg end (completion-table-dynamic #'slime-simple-completions))))
+ (list beg end (slime-simple-completions))))
(defun slime-filename-completion ()
"If point is at a string starting with \", complete it as filename.
@@ -3713,12 +3713,10 @@ alist but ignores CDRs."
(mapcar (lambda (x) (cons x nil)) list))
(defun slime-simple-completions (prefix)
- (cl-destructuring-bind (completions _partial)
- (let ((slime-current-thread t))
- (slime-eval
- `(swank:simple-completions ,(substring-no-properties prefix)
- ',(slime-current-package))))
- completions))
+ (let ((slime-current-thread t))
+ (slime-eval
+ `(swank:simple-completions ,(substring-no-properties prefix)
+ ',(slime-current-package)))))
;;;; Edit definition
diff --git a/swank.lisp b/swank.lisp
index 8664b4bb271..33f2b91bf57 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -2663,8 +2663,7 @@ the filename of the module (or nil if the file doesn't
exist).")
(defslimefun simple-completions (prefix package)
"Return a list of completions for the string PREFIX."
- (let ((strings (all-completions prefix package)))
- (list strings (longest-common-prefix strings))))
+ (all-completions prefix package))
(defun all-completions (prefix package)
(multiple-value-bind (name pname intern) (tokenize-symbol prefix)
@@ -2677,7 +2676,7 @@ the filename of the module (or nil if the file doesn't
exist).")
(strings (loop for sym in syms
for str = (unparse-symbol sym)
when (prefix-match-p name str) ; remove |Foo|
- collect str)))
+ collect (cons str sym))))
(format-completion-set strings intern pname))))
(defun matching-symbols (package external test)
@@ -2712,11 +2711,45 @@ the filename of the module (or nil if the file doesn't
exist).")
(if diff-pos (subseq s1 0 diff-pos) s1))))
(reduce #'common-prefix strings))))
+(defun symbol-classification-string (symbol)
+ "Return a string in the form -f-c---- where each letter stands for
+boundp fboundp generic-function class macro special-operator package accessor"
+ (let ((letters "bfgctmspa")
+ (result (copy-seq "---------")))
+ (flet ((flip (letter)
+ (setf (char result (position letter letters))
+ letter)))
+ (when (boundp symbol) (flip #\b))
+ (when (fboundp symbol)
+ (flip #\f)
+ (when (typep (ignore-errors (fdefinition symbol))
+ 'generic-function)
+ (flip #\g)))
+ (when (type-specifier-p symbol) (flip #\t))
+ (when (find-class symbol nil) (flip #\c) )
+ (when (macro-function symbol) (flip #\m))
+ (when (special-operator-p symbol) (flip #\s))
+ (when (find-package symbol) (flip #\p))
+ (when (structure-accessor-p symbol) (flip #\a))
+ result)))
+
(defun format-completion-set (strings internal-p package-name)
"Format a set of completion strings.
Returns a list of completions with package qualifiers if needed."
- (mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
- (sort strings #'string<)))
+ (with-standard-io-syntax
+ (let ((*package* (find-package :keyword)))
+ (sort (mapcar (lambda (c)
+ (if (stringp c)
+ (list (untokenize-symbol package-name internal-p c))
+ (destructuring-bind (name &rest symbol) c
+ (list* (untokenize-symbol package-name internal-p
name)
+ (if (stringp symbol)
+ symbol
+ (symbol-classification-string symbol))
+ (when (symbolp symbol)
+ (list (write-to-string symbol :readably
t)))))))
+ strings)
+ #'string< :key #'car))))
;;;; Simple arglist display
