summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp')
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp298
1 files changed, 298 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp
new file mode 100644
index 0000000..6a766fb
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp
@@ -0,0 +1,298 @@
+;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
+;;
+;; Author: Luke Gorrie <luke@synap.se>
+;; Edi Weitz <edi@agharta.de>
+;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr@freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-util))
+
+(defslimefun completions (string default-package-name)
+ "Return a list of completions for a symbol designator STRING.
+
+The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
+COMPLETION-SET is the list of all matching completions, and
+COMPLETED-PREFIX is the best (partial) completion of the input
+string.
+
+Simple compound matching is supported on a per-hyphen basis:
+
+ (completions \"m-v-\" \"COMMON-LISP\")
+ ==> ((\"multiple-value-bind\" \"multiple-value-call\"
+ \"multiple-value-list\" \"multiple-value-prog1\"
+ \"multiple-value-setq\" \"multiple-values-limit\")
+ \"multiple-value\")
+
+\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
+
+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.
+
+The way symbols are matched depends on the symbol designator's
+format. The cases are as follows:
+ FOO - Symbols with matching prefix and accessible in the buffer package.
+ PKG:FOO - Symbols with matching prefix and external in package PKG.
+ PKG::FOO - Symbols with matching prefix and accessible in package PKG.
+"
+ (multiple-value-bind (name package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (let* ((symbol-set (symbol-completion-set
+ name package-name package internal-p
+ (make-compound-prefix-matcher #\-)))
+ (package-set (package-completion-set
+ name package-name package internal-p
+ (make-compound-prefix-matcher '(#\. #\-))))
+ (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))))))
+
+
+;;;;; 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)))))
+
+(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))))
+
+(defun find-matching-symbols (string package external test)
+ "Return a list of symbols in PACKAGE matching STRING.
+TEST is called with two strings. If EXTERNAL is true, only external
+symbols are returned."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (and (or (not external)
+ (symbol-external-p symbol package))
+ (funcall test string
+ (funcall converter (symbol-name symbol))))))
+ (do-symbols* (symbol package)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ completions))
+
+(defun find-matching-symbols-in-list (string list test)
+ "Return a list of symbols in LIST matching STRING.
+TEST is called with two strings."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (funcall test string
+ (funcall converter (symbol-name symbol)))))
+ (dolist (symbol list)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ (remove-duplicates completions)))
+
+(defun find-matching-packages (name matcher)
+ "Return a list of package names matching NAME with MATCHER.
+MATCHER is a two-argument predicate."
+ (let ((converter (completion-output-package-converter name)))
+ (remove-if-not (lambda (x)
+ (funcall matcher name (funcall converter x)))
+ (mapcar (lambda (pkgname)
+ (concatenate 'string pkgname ":"))
+ (loop for package in (list-all-packages)
+ nconcing (package-names package))))))
+
+
+;; PARSE-COMPLETION-ARGUMENTS return table:
+;;
+;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
+;; ----------------+--------+--------------+-----------------------------------
+;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
+;; | | | or *BUFFER-PACKAGE*
+;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; as:fo [tab] | "fo" | "as" | NIL
+;; | | |
+;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
+;; | | |
+;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
+;;
+(defun parse-completion-arguments (string default-package-name)
+ "Parse STRING as a symbol designator.
+Return these values:
+ SYMBOL-NAME
+ PACKAGE-NAME, or nil if the designator does not include an explicit package.
+ PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
+ NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
+ if PACKAGE is non-NIL but a package cannot be found under that name,
+ return NIL.)
+ INTERNAL-P, if the symbol is qualified with `::'."
+ (multiple-value-bind (name package-name internal-p)
+ (tokenize-symbol string)
+ (flet ((default-package ()
+ (or (guess-package default-package-name) *buffer-package*)))
+ (let ((package (cond
+ ((not package-name)
+ (default-package))
+ ((equal package-name "")
+ (guess-package (symbol-name :keyword)))
+ ((find-locally-nicknamed-package
+ package-name (default-package)))
+ (t
+ (guess-package package-name)))))
+ (values name package-name package internal-p)))))
+
+(defun completion-output-case-converter (input &optional with-escaping-p)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (ecase (readtable-case *readtable*)
+ (:upcase (cond ((or with-escaping-p
+ (and (plusp (length input))
+ (not (some #'lower-case-p input))))
+ #'identity)
+ (t #'string-downcase)))
+ (:invert (lambda (output)
+ (multiple-value-bind (lower upper) (determine-case output)
+ (cond ((and lower upper) output)
+ (lower (string-upcase output))
+ (upper (string-downcase output))
+ (t output)))))
+ (:downcase (cond ((or with-escaping-p
+ (and (zerop (length input))
+ (not (some #'upper-case-p input))))
+ #'identity)
+ (t #'string-upcase)))
+ (:preserve #'identity)))
+
+(defun completion-output-package-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (completion-output-case-converter input))
+
+(defun completion-output-symbol-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case. Escape symbols when needed."
+ (let ((case-converter (completion-output-case-converter input))
+ (case-converter-with-escaping (completion-output-case-converter input t)))
+ (lambda (str)
+ (if (or (multiple-value-bind (lowercase uppercase)
+ (determine-case str)
+ ;; In these readtable cases, symbols with letters from
+ ;; the wrong case need escaping
+ (case (readtable-case *readtable*)
+ (:upcase lowercase)
+ (:downcase uppercase)
+ (t nil)))
+ (some (lambda (el)
+ (or (member el '(#\: #\Space #\Newline #\Tab))
+ (multiple-value-bind (macrofun nonterminating)
+ (get-macro-character el)
+ (and macrofun
+ (not nonterminating)))))
+ str))
+ (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
+ (funcall case-converter str)))))
+
+
+(defun determine-case (string)
+ "Return two booleans LOWER and UPPER indicating whether STRING
+contains lower or upper case characters."
+ (values (some #'lower-case-p string)
+ (some #'upper-case-p string)))
+
+
+;;;;; Compound-prefix matching
+
+(defun make-compound-prefix-matcher (delimiter &key (test #'char=))
+ "Returns a matching function that takes a `prefix' and a
+`target' string and which returns T if `prefix' is a
+compound-prefix of `target', and otherwise NIL.
+
+Viewing each of `prefix' and `target' as a series of substrings
+delimited by DELIMITER, if each substring of `prefix' is a prefix
+of the corresponding substring in `target' then we call `prefix'
+a compound-prefix of `target'.
+
+DELIMITER may be a character, or a list of characters."
+ (let ((delimiters (etypecase delimiter
+ (character (list delimiter))
+ (cons (assert (every #'characterp delimiter))
+ delimiter))))
+ (lambda (prefix target)
+ (declare (type simple-string prefix target))
+ (loop with tpos = 0
+ for ch across prefix
+ always (and (< tpos (length target))
+ (let ((delimiter (car (member ch delimiters :test test))))
+ (if delimiter
+ (setf tpos (position delimiter target :start tpos))
+ (funcall test ch (aref target tpos)))))
+ do (incf tpos)))))
+
+
+;;;;; 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
+ for start = 0 then (1+ end)
+ until (> start (length string))
+ do (setq end (or (position delimiter string :start start) (length string)))
+ collect (subseq string start end)))
+
+(defun untokenize-completion (tokens &optional (delimiter #\-))
+ (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens))
+
+(defun transpose-lists (lists)
+ "Turn a list-of-lists on its side.
+If the rows are of unequal length, truncate uniformly to the shortest.
+
+For example:
+\(transpose-lists '((ONE TWO THREE) (1 2)))
+ => ((ONE 1) (TWO 2))"
+ (cond ((null lists) '())
+ ((some #'null lists) '())
+ (t (cons (mapcar #'car lists)
+ (transpose-lists (mapcar #'cdr lists))))))
+
+
+;;;; Completion for character names
+
+(defslimefun completions-for-character (prefix)
+ (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 #\_))))
+
+(provide :swank-c-p-c)
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-05 15:44:28 +0000