slynk-completion.lisp (19395B)
1 ;;; slynk-flex-completion.lisp --- Common Lisp symbol completion routines 2 ;; 3 ;; Authors: João Távora, some parts derivative works of SLIME, by its 4 ;; authors. 5 ;; 6 (defpackage :slynk-completion 7 (:use #:cl #:slynk-api) 8 (:export 9 #:flex-completions 10 #:simple-completions 11 #:flex-matches)) 12 13 ;; for testing package-local nicknames 14 #+sbcl 15 (defpackage :slynk-completion-local-nicknames-test 16 (:use #:cl) 17 (:local-nicknames (#:api #:slynk-api))) 18 19 (in-package :slynk-completion) 20 21 22 ;;; Simple completion 23 ;;; 24 (defslyfun simple-completions (prefix package) 25 "Return a list of completions for the string PREFIX." 26 (let ((strings (all-simple-completions prefix package))) 27 (list strings (longest-common-prefix strings)))) 28 29 (eval-when (:compile-toplevel :load-toplevel :execute) 30 (import 'simple-completions :slynk) 31 (export 'simple-completions :slynk)) 32 33 (defun all-simple-completions (prefix package) 34 (multiple-value-bind (name pname intern) (tokenize-symbol prefix) 35 (let* ((extern (and pname (not intern))) 36 (pkg (cond ((equal pname "") +keyword-package+) 37 ((not pname) (guess-buffer-package package)) 38 (t (guess-package pname)))) 39 (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) 40 (syms (and pkg (matching-symbols pkg extern test))) 41 (strings (loop for sym in syms 42 for str = (unparse-symbol sym) 43 when (prefix-match-p name str) ; remove |Foo| 44 collect str))) 45 (format-completion-set strings intern pname)))) 46 47 (defun matching-symbols (package external test) 48 (let ((test (if external 49 (lambda (s) 50 (and (symbol-external-p s package) 51 (funcall test s))) 52 test)) 53 (result '())) 54 (do-symbols (s package) 55 (when (funcall test s) 56 (push s result))) 57 (remove-duplicates result))) 58 59 (defun unparse-symbol (symbol) 60 (let ((*print-case* (case (readtable-case *readtable*) 61 (:downcase :upcase) 62 (t :downcase)))) 63 (unparse-name (symbol-name symbol)))) 64 65 (defun prefix-match-p (prefix string) 66 "Return true if PREFIX is a prefix of STRING." 67 (not (mismatch prefix string :end2 (min (length string) (length prefix)) 68 :test #'char-equal))) 69 70 (defun longest-common-prefix (strings) 71 "Return the longest string that is a common prefix of STRINGS." 72 (if (null strings) 73 "" 74 (flet ((common-prefix (s1 s2) 75 (let ((diff-pos (mismatch s1 s2))) 76 (if diff-pos (subseq s1 0 diff-pos) s1)))) 77 (reduce #'common-prefix strings)))) 78 79 (defun format-completion-set (strings internal-p package-name) 80 "Format a set of completion strings. 81 Returns a list of completions with package qualifiers if needed." 82 (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) 83 (sort strings #'string<))) 84 85 86 87 88 ;;; Fancy "flex" completion 89 ;;; 90 (defmacro collecting ((&rest collectors) &body body) ; lifted from uiop 91 "COLLECTORS should be a list of names for collections. A collector 92 defines a function that, when applied to an argument inside BODY, will 93 add its argument to the corresponding collection. Returns multiple values, 94 a list for each collection, in order. 95 E.g., 96 \(collecting \(foo bar\) 97 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) 98 \(foo \(first x\)\) 99 \(bar \(second x\)\)\)\) 100 Returns two values: \(A B C\) and \(1 2 3\)." 101 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) 102 (initial-values (mapcar (constantly nil) collectors))) 103 `(let ,(mapcar #'list vars initial-values) 104 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) 105 ,@body 106 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) 107 108 (defun to-chunks (string indexes) 109 "Return chunks of STRING in as specified by INDEXES." 110 ;; (to-chunks "farfalhini" '(1 2 3 4)) => ((1 "arfa")) 111 ;; (to-chunks "farfalhini" '(1 3 4)) => ((1 "a") (3 "fa")) 112 ;; (to-chunks "farfalhini" '(1 2 3 4 5 7 8 9)) => ((1 "arfal") (7 "ini")) 113 ;; (to-chunks "farfalhini" '(1 2 3 4 5 6 7 8 9)) => ((1 "arfalhini")) 114 (reverse (reduce (lambda (chunk-list number) 115 (let ((latest-chunk (car chunk-list))) 116 (if (and latest-chunk 117 (= (+ 118 (length (second latest-chunk)) 119 (first latest-chunk)) 120 number)) 121 (progn (setf (second latest-chunk) 122 (format nil "~a~c" (second latest-chunk) 123 (aref string number))) 124 chunk-list) 125 (cons (list number (format nil "~c" (aref string number))) 126 chunk-list)))) 127 indexes 128 :initial-value nil))) 129 130 (defun readably-classify (sym) 131 (let* ((translations '((:fboundp . "fn") 132 (:class . "cla") 133 (:typespec . "type") 134 (:generic-function . "generic-fn") 135 (:macro . "macro") 136 (:special-operator . "special-op") 137 (:package . "pak") 138 (:boundp . "var") 139 (:constant . "constant"))) 140 (classes (slynk::classify-symbol sym)) 141 (classes (if (some (lambda (m) (member m classes)) '(:generic-function :macro)) 142 (delete :fboundp classes) 143 classes)) 144 (translated (mapcar (lambda (cla) (cdr (assoc cla translations))) 145 classes))) 146 (format nil "~{~a~^,~}" translated))) 147 148 (defparameter *flex-score-falloff* 1.5 149 "The larger the value, the more big index distances are penalized.") 150 151 (defparameter *more-qualified-matches* t 152 "If non-nil, \"foo\" more likely completes to \"bar:foo\". 153 Specifically this assigns a \"foo\" on \"bar:foo\" a 154 higher-than-usual score, as if the package qualifier \"bar\" was 155 shorter.") 156 157 (defun flex-score (string indexes pattern) 158 "Score the match of STRING as given by INDEXES. 159 INDEXES as calculated by FLEX-MATCHES." 160 (let* ((first-pattern-colon (and pattern 161 (position #\: pattern))) 162 (index-of-first-pattern-colon (and first-pattern-colon 163 (elt indexes first-pattern-colon))) 164 (first-string-colon) 165 (string-length (length string))) 166 (cond ((and first-pattern-colon 167 (plusp first-pattern-colon)) 168 ;; If the user included a colon (":") in the pattern, score 169 ;; the pre-colon and post-colon parts separately and add 170 ;; the resulting halves together. This tends to fare 171 ;; slightly better when matching qualified symbols. 172 (let ((package-designator-score 173 (flex-score-1 index-of-first-pattern-colon 174 (subseq indexes 0 first-pattern-colon))) 175 (symbol-name-score 176 (flex-score-1 (- string-length 177 index-of-first-pattern-colon) 178 (mapcar (lambda (index) 179 (- index index-of-first-pattern-colon)) 180 (subseq indexes (1+ first-pattern-colon)))))) 181 (+ (/ package-designator-score 2) 182 (/ symbol-name-score 2)))) 183 ((and 184 *more-qualified-matches* 185 (setf first-string-colon (position #\: string)) 186 (< first-string-colon 187 (car indexes))) 188 ;; If the user did not include a colon, but the string 189 ;; we're matching again does have that colon (we're 190 ;; matching a qualified name), and the position of that 191 ;; colon happens to be less than the first index, then act 192 ;; as if the pre-colon part were actually half the size of 193 ;; what it is. This also tends to promote qualified matches 194 ;; meant on the symbol-name. 195 (let ((adjust (truncate (/ first-string-colon 2)))) 196 (flex-score-1 (- string-length 197 adjust) 198 (mapcar (lambda (idx) 199 (- idx adjust)) 200 indexes)))) 201 (t 202 ;; the default: score the whole pattern on the whole 203 ;; string. 204 (flex-score-1 string-length indexes))))) 205 206 (defun flex-score-1 (string-length indexes) 207 "Does the real work of FLEX-SCORE. 208 Given that INDEXES is a list of integer position of characters in a 209 string of length STRING-LENGTH, say how well these characters 210 represent that STRING. There is a non-linear falloff with the 211 distances between the indexes, according to *FLEX-SCORE-FALLOFF*. If 212 that value is 2, for example, the indices '(0 1 2) on a 3-long 213 string of is a perfect (100% match,) while '(0 2) on that same 214 string is a 33% match and just '(1) is a 11% match." 215 (float 216 (/ (length indexes) 217 (* string-length 218 (+ 1 (reduce #'+ 219 (loop for i from 0 220 for (a b) on `(,-1 221 ,@indexes 222 ,string-length) 223 while b 224 collect (expt (- b a 1) *flex-score-falloff*)))))))) 225 226 (defun flex-matches (pattern string char-test) 227 "Return non-NIL if PATTERN flex-matches STRING. 228 In case of a match, return two values: 229 230 A list of non-negative integers which are the indexes of the 231 characters in PATTERN as found consecutively in STRING. This list 232 measures in length the number of characters in PATTERN. 233 234 A floating-point score. Higher scores for better matches." 235 (declare (optimize (speed 3) (safety 0)) 236 (type simple-string string) 237 (type simple-string pattern) 238 (type function char-test)) 239 (let* ((strlen (length string)) 240 (indexes (loop for char across pattern 241 for from = 0 then (1+ pos) 242 for pos = (loop for i from from below strlen 243 when (funcall char-test 244 (aref string i) char) 245 return i) 246 unless pos 247 return nil 248 collect pos))) 249 (values indexes 250 (and indexes 251 (flex-score string indexes pattern))))) 252 253 (defun collect-if-matches (collector pattern string symbol) 254 "Make and collect a match with COLLECTOR if PATTERN matches STRING. 255 A match is a list (STRING SYMBOL INDEXES SCORE). 256 Return non-nil if match was collected, nil otherwise." 257 (multiple-value-bind (indexes score) 258 (flex-matches pattern string #'char=) 259 (when indexes 260 (funcall collector 261 (list string 262 symbol 263 indexes 264 score))))) 265 266 (defun sort-by-score (matches) 267 "Sort MATCHES by SCORE, highest score first. 268 269 Matches are produced by COLLECT-IF-MATCHES (which see)." 270 (sort matches #'> :key #'fourth)) 271 272 (defun keywords-matching (pattern) 273 "Find keyword symbols flex-matching PATTERN. 274 Return an unsorted list of matches. 275 276 Matches are produced by COLLECT-IF-MATCHES (which see)." 277 (collecting (collect) 278 (and (char= (aref pattern 0) #\:) 279 (do-symbols (s +keyword-package+) 280 (collect-if-matches #'collect pattern (concatenate 'simple-string ":" 281 (symbol-name s)) 282 s))))) 283 284 (defun accessible-matching (pattern package) 285 "Find symbols flex-matching PATTERN accessible without package-qualification. 286 Return an unsorted list of matches. 287 288 Matches are produced by COLLECT-IF-MATCHES (which see)." 289 (and (not (find #\: pattern)) 290 (collecting (collect) 291 (let ((collected (make-hash-table))) 292 (do-symbols (s package) 293 ;; XXX: since DO-SYMBOLS may visit a symbol more than 294 ;; once. Read similar note apropos DO-ALL-SYMBOLS in 295 ;; QUALIFIED-MATCHING for how we do it. 296 (collect-if-matches 297 (lambda (thing) 298 (unless (gethash s collected) 299 (setf (gethash s collected) t) 300 (funcall #'collect thing))) 301 pattern (symbol-name s) s)))))) 302 303 (defun qualified-matching (pattern home-package) 304 "Find package-qualified symbols flex-matching PATTERN. 305 Return, as two values, a set of matches for external symbols, 306 package-qualified using one colon, and another one for internal 307 symbols, package-qualified using two colons. 308 309 The matches in the two sets are not guaranteed to be in their final 310 order, i.e. they are not sorted (except for the fact that 311 qualifications with shorter package nicknames are tried first). 312 313 Matches are produced by COLLECT-IF-MATCHES (which see)." 314 (let* ((first-colon (position #\: pattern)) 315 (starts-with-colon (and first-colon (zerop first-colon))) 316 (two-colons (and first-colon (< (1+ first-colon) (length pattern)) 317 (eq #\: (aref pattern (1+ first-colon)))))) 318 (if (and starts-with-colon 319 (not two-colons)) 320 (values nil nil) 321 (let* ((package-local-nicknames 322 (slynk-backend:package-local-nicknames home-package)) 323 (package-local-nicknames-by-package 324 (let ((ret (make-hash-table))) 325 (loop for (short . full) in 326 package-local-nicknames 327 do (push short (gethash (find-package full) 328 ret))) 329 ret)) 330 (nicknames-by-package (make-hash-table))) 331 (flet ((sorted-nicknames (package) 332 (or (gethash package nicknames-by-package) 333 (setf (gethash package nicknames-by-package) 334 (sort (append 335 (gethash package package-local-nicknames-by-package) 336 (package-nicknames package) 337 (list (package-name package))) 338 #'< 339 :key #'length))))) 340 (collecting (collect-external collect-internal) 341 (cond 342 (two-colons 343 (let ((collected (make-hash-table))) 344 (do-all-symbols (s) 345 (loop 346 with package = (symbol-package s) 347 for nickname in (and package ; gh#226 348 (sorted-nicknames package)) 349 do (collect-if-matches 350 (lambda (thing) 351 ;; XXX: since DO-ALL-SYMBOLS may visit 352 ;; a symbol more than once, we want to 353 ;; avoid double collections. But 354 ;; instead of marking every traversed 355 ;; symbol in a hash table, we mark just 356 ;; those collected. We do pay an added 357 ;; price of checking matching duplicate 358 ;; symbols, but the much smaller hash 359 ;; table pays off when benchmarked, 360 ;; because the number of collections is 361 ;; generally much smaller than the 362 ;; total number of symbols. 363 (unless (gethash s collected) 364 (setf (gethash s collected) t) 365 (funcall #'collect-internal thing))) 366 pattern 367 (concatenate 'simple-string 368 nickname 369 "::" 370 (symbol-name s)) 371 s))))) 372 (t 373 (loop 374 with use-list = (package-use-list home-package) 375 for package in (remove +keyword-package+ (list-all-packages)) 376 for sorted-nicknames 377 = (and (not (eq package home-package)) 378 (sorted-nicknames package)) 379 do (when sorted-nicknames 380 (do-external-symbols (s package) 381 ;;; XXX: This condition is slightly 382 ;;; opinionated. It says, for example, that 383 ;;; you never want to complete "c:del" to 384 ;;; "cl:delete" or "common-lisp:delete" in 385 ;;; packages that use :CL (a very common 386 ;;; case). 387 (when (or first-colon 388 (not (member (symbol-package s) use-list))) 389 (loop for nickname in sorted-nicknames 390 do (collect-if-matches #'collect-external 391 pattern 392 (concatenate 'simple-string 393 nickname 394 ":" 395 (symbol-name s)) 396 s)))))))))))))) 397 398 (defslyfun flex-completions (pattern package-name &key (limit 300)) 399 "Compute \"flex\" completions for PATTERN given current PACKAGE-NAME. 400 Returns a list of (COMPLETIONS NIL). COMPLETIONS is a list of 401 \(STRING SCORE CHUNKS CLASSIFICATION-STRING)." 402 (when (plusp (length pattern)) 403 (list (loop 404 with package = (guess-buffer-package package-name) 405 with upcasepat = (string-upcase pattern) 406 for (string symbol indexes score) 407 in 408 (loop with (external internal) 409 = (multiple-value-list (qualified-matching upcasepat package)) 410 for e in (append (sort-by-score 411 (keywords-matching upcasepat)) 412 (sort-by-score 413 (append (accessible-matching upcasepat package) 414 external)) 415 (sort-by-score 416 internal)) 417 for i upto limit 418 collect e) 419 collect 420 (list (if (every #'common-lisp:upper-case-p pattern) 421 (string-upcase string) 422 (string-downcase string)) 423 score 424 (to-chunks string indexes) 425 (readably-classify symbol))) 426 nil))) 427 428 (provide :slynk/completion)