klimi
/
dotfiles


								;;; 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)