sly-completion.el (32104B)
1 ;;; sly-completion.el --- completion tricks and helpers -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2016 João Távora 4 5 ;; Author: João Távora 6 ;; Keywords: 7 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 12 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 17 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 20 21 ;;; Commentary: 22 23 ;; 24 25 ;;; Code: 26 ;;; 27 (require 'cl-lib) 28 (require 'comint) 29 (require 'sly-messages "lib/sly-messages") 30 31 32 ;;; Something to move to minibuffer.el, maybe 33 34 ;;; Backend completion 35 36 ;; This "completion style" delegates all the work to the completion 37 ;; table which is then free to implement its own completion style. 38 ;; Typically this is used to take advantage of some external tool which 39 ;; already has its own completion system and doesn't give you efficient 40 ;; access to the prefix completion needed by other completion styles. 41 42 (add-to-list 'completion-styles-alist 43 '(backend 44 completion-backend-try-completion 45 completion-backend-all-completions 46 "Ad-hoc completion style provided by the completion table")) 47 48 (defun completion--backend-call (op string table pred point) 49 (when (functionp table) 50 (let ((res (funcall table string pred (cons op point)))) 51 (when (eq op (car-safe res)) 52 (cdr res))))) 53 54 (defun completion-backend-try-completion (string table pred point) 55 (completion--backend-call 'try-completion string table pred point)) 56 57 (defun completion-backend-all-completions (string table pred point) 58 (completion--backend-call 'all-completions string table pred point)) 59 60 61 ;;; Forward declarations (later replace with a `sly-common' lib) 62 ;;; 63 (defvar sly-current-thread) 64 65 (declare-function sly-eval "sly" (sexp &optional package 66 cancel-on-input 67 cancel-on-input-retval)) 68 69 (declare-function sly-symbol-at-point "sly") 70 71 (declare-function sly-buffer-name "sly") 72 73 (defvar sly-buffer-package) 74 75 (defvar sly-buffer-connection) 76 77 (declare-function sly-connection "sly") 78 79 (declare-function sly-recenter "sly") 80 81 (declare-function sly-symbol-start-pos "sly") 82 83 (declare-function sly-symbol-end-pos "sly") 84 85 (declare-function sly-current-package "sly") 86 87 (declare-function with-displayed-buffer-window "window") 88 89 90 ;;; Backward compatibility shim for emacs < 25. 91 ;;; 92 (eval-when-compile 93 (unless (fboundp 'with-displayed-buffer-window) 94 (defmacro with-displayed-buffer-window (buffer-or-name action quit-function &rest body) 95 "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. 96 This construct is like `with-current-buffer-window' but unlike that 97 displays the buffer specified by BUFFER-OR-NAME before running BODY." 98 (declare (debug t)) 99 (let ((buffer (make-symbol "buffer")) 100 (window (make-symbol "window")) 101 (value (make-symbol "value"))) 102 (macroexp-let2 nil vbuffer-or-name buffer-or-name 103 (macroexp-let2 nil vaction action 104 (macroexp-let2 nil vquit-function quit-function 105 `(let* ((,buffer (temp-buffer-window-setup ,vbuffer-or-name)) 106 (standard-output ,buffer) 107 ,window ,value) 108 (with-current-buffer ,buffer 109 (setq ,window (temp-buffer-window-show 110 ,buffer 111 ;; Remove window-height when it's handled below. 112 (if (functionp (cdr (assq 'window-height (cdr ,vaction)))) 113 (assq-delete-all 'window-height (copy-sequence ,vaction)) 114 ,vaction)))) 115 116 (let ((inhibit-read-only t) 117 (inhibit-modification-hooks t)) 118 (setq ,value (progn ,@body))) 119 120 (set-window-point ,window (point-min)) 121 122 (when (functionp (cdr (assq 'window-height (cdr ,vaction)))) 123 (ignore-errors 124 (funcall (cdr (assq 'window-height (cdr ,vaction))) ,window))) 125 126 (if (functionp ,vquit-function) 127 (funcall ,vquit-function ,window ,value) 128 ,value))))))))) 129 130 131 132 ;;; Customization 133 ;;; 134 (defcustom sly-complete-symbol-function 'sly-flex-completions 135 "Function reponsible for SLY completion. 136 When called with one argument, a pattern, returns a (possibly 137 propertized) list of strings the complete that pattern, 138 collected from the Slynk server." 139 :type 'function 140 :group 'sly-ui) 141 142 143 (cl-defmacro sly--responsive-eval ((var sexp 144 &optional 145 package 146 input-arrived-retval) &rest body) 147 "Use `sly-eval' on SEXP, PACKAGE, bind to VAR, run BODY. 148 If user input arrives in the meantime return INPUT-ARRIVED-RETVAL 149 immediately." 150 (declare (indent 1) (debug (sexp &rest form))) 151 (let ((sym (make-symbol "sly--responsive-eval"))) 152 `(let* ((,sym (make-symbol "sly--responsive-eval-unique")) 153 (,var (sly-eval ,sexp ,package non-essential ,sym))) 154 (if (eq ,var ,sym) 155 ,input-arrived-retval 156 ,@body)))) 157 158 159 ;;; Completion calculation 160 ;;; 161 (defun sly--completion-request-completions (pattern slyfun) 162 "Request completions for PATTERN using SLYFUN. 163 SLYFUN takes two arguments, a pattern and a package." 164 (let* ((sly-current-thread t)) 165 (sly--responsive-eval 166 (completions `(,slyfun ,(substring-no-properties pattern) 167 ',(sly-current-package))) 168 completions))) 169 170 (defun sly-simple-completions (prefix) 171 "Return (COMPLETIONS COMMON) where COMPLETIONS complete the PREFIX. 172 COMPLETIONS is a list of propertized strings. 173 COMMON a string, the common prefix." 174 (cl-loop with first-difference-pos = (length prefix) 175 with (completions common) = 176 (sly--completion-request-completions prefix 'slynk-completion:simple-completions) 177 for completion in completions 178 do (put-text-property first-difference-pos 179 (min (1+ first-difference-pos) 180 (1- (length completion))) 181 'face 182 'completions-first-difference 183 completion) 184 collect completion into formatted 185 finally return (list formatted common))) 186 187 (defun sly-flex-completions (pattern) 188 "Return (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. 189 COMPLETIONS is a list of propertized strings." 190 (cl-loop with (completions _) = 191 (sly--completion-request-completions pattern 'slynk-completion:flex-completions) 192 for (completion score chunks classification suggestion) in completions 193 do 194 (cl-loop for (pos substring) in chunks 195 do (put-text-property pos (+ pos 196 (length substring)) 197 'face 198 'completions-first-difference 199 completion) 200 collect `(,pos . ,(+ pos (length substring))) into chunks-2 201 finally (put-text-property 0 (length completion) 202 'sly-completion-chunks chunks-2 203 completion)) 204 (add-text-properties 0 205 (length completion) 206 `(sly--annotation 207 ,(format "%s %5.2f%%" 208 classification 209 (* score 100)) 210 sly--suggestion 211 ,suggestion) 212 completion) 213 214 collect completion into formatted 215 finally return (list formatted nil))) 216 217 (defun sly-completion-annotation (completion) 218 "Grab the annotation of COMPLETION, a string, if any" 219 (get-text-property 0 'sly--annotation completion)) 220 221 ;;; backward-compatibility 222 (defun sly-fuzzy-completions (pattern) 223 "This function is obsolete since 1.0.0-beta-2; 224 use ‘sly-flex-completions’ instead, but notice the updated protocol. 225 226 Returns (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. 227 228 COMPLETIONS is a list of elements of the form (STRING NIL NIL 229 ANNOTATION) describing each completion possibility." 230 (let ((new (sly-flex-completions pattern))) 231 (list (mapcar (lambda (string) 232 (list string nil nil (sly-completion-annotation string))) 233 (car new)) 234 (cadr new)))) 235 236 ;; TODO: this `basic' completion style is actually a `backend' 237 ;; completion style, meaning a completion style where the filtering is 238 ;; done entirely by the backend. 239 (when (boundp 'completion-category-defaults) 240 (add-to-list 'completion-category-defaults 241 '(sly-completion (styles . (backend))))) 242 243 (defun sly--completion-function-wrapper (fn) 244 (let ((cache (make-hash-table :test #'equal))) 245 (lambda (string pred action) 246 (cl-labels ((all 247 () 248 (let ((probe (gethash string cache :missing))) 249 (if (eq probe :missing) 250 (puthash string (funcall fn string) cache) 251 probe))) 252 (try () 253 (let ((all (all))) 254 (and (car all) 255 (if (and (null (cdr (car all))) 256 (string= string (caar all))) 257 t 258 string))))) 259 (pcase action 260 ;; identify this to the custom `sly--completion-in-region-function' 261 (`sly--identify t) 262 ;; identify this to other UI's 263 (`metadata '(metadata 264 (display-sort-function . identity) 265 (category . sly-completion))) 266 ;; all completions 267 (`t (car (all))) 268 ;; try completion 269 (`nil (try)) 270 (`(try-completion . ,point) 271 (cons 'try-completion (cons string point))) 272 (`(all-completions . ,_point) (cons 'all-completions (car (all)))) 273 (`(boundaries . ,thing) 274 (completion-boundaries string (all) pred thing)) 275 276 ;; boundaries or any other value 277 (_ nil)))))) 278 279 ;; This duplicates a function in sly-parse.el 280 (defun sly--completion-inside-string-or-comment-p () 281 (let ((ppss (syntax-ppss))) (or (nth 3 ppss) (nth 4 ppss)))) 282 283 (defun sly--completions-complete-symbol-1 (fn) 284 (let* ((beg (sly-symbol-start-pos)) 285 (end (sly-symbol-end-pos))) 286 (list beg end 287 (sly--completion-function-wrapper fn) 288 :annotation-function #'sly-completion-annotation 289 :exit-function (lambda (obj _status) 290 (let ((suggestion 291 (get-text-property 0 'sly--suggestion 292 obj))) 293 (when suggestion 294 (delete-region (- (point) (length obj)) (point)) 295 (insert suggestion)))) 296 :company-docsig 297 (lambda (obj) 298 (when (sit-for 0.1) 299 (sly--responsive-eval (arglist `(slynk:operator-arglist 300 ,(substring-no-properties obj) 301 ,(sly-current-package))) 302 (or (and arglist 303 (sly-autodoc--fontify arglist)) 304 "no autodoc information")))) 305 :company-no-cache t 306 :company-doc-buffer 307 (lambda (obj) 308 (when (sit-for 0.1) 309 (sly--responsive-eval (doc `(slynk:describe-symbol 310 ,(substring-no-properties obj))) 311 (when doc 312 (with-current-buffer (get-buffer-create " *sly-completion doc*") 313 (erase-buffer) 314 (insert doc) 315 (current-buffer)))))) 316 :company-require-match 'never 317 :company-match 318 (lambda (obj) 319 (get-text-property 0 'sly-completion-chunks obj)) 320 :company-location 321 (lambda (obj) 322 (save-window-excursion 323 (let* ((buffer (sly-edit-definition 324 (substring-no-properties obj)))) 325 (when (buffer-live-p buffer) ; on the safe side 326 (cons buffer (with-current-buffer buffer 327 (point))))))) 328 :company-prefix-length 329 (and (sly--completion-inside-string-or-comment-p) 0)))) 330 331 (defun sly-simple-complete-symbol () 332 "Prefix completion on the symbol at point. 333 Intended to go into `completion-at-point-functions'" 334 (sly--completions-complete-symbol-1 'sly-simple-completions)) 335 336 (defun sly-flex-complete-symbol () 337 "\"Flex\" completion on the symbol at point. 338 Intended to go into `completion-at-point-functions'" 339 (sly--completions-complete-symbol-1 'sly-flex-completions)) 340 341 (defun sly-complete-symbol () 342 "Completion on the symbol at point, using `sly-complete-symbol-function' 343 Intended to go into `completion-at-point-functions'" 344 (sly--completions-complete-symbol-1 sly-complete-symbol-function)) 345 346 (defun sly-complete-filename-maybe () 347 (when (nth 3 (syntax-ppss)) (comint-filename-completion))) 348 349 350 ;;; Set `completion-at-point-functions' and a few other tricks 351 ;;; 352 (defun sly--setup-completion () 353 ;; This one can be customized by a SLY user in `sly-mode-hook' 354 ;; 355 (setq-local completion-at-point-functions '(sly-complete-filename-maybe 356 sly-complete-symbol)) 357 (add-function :around (local 'completion-in-region-function) 358 (lambda (oldfun &rest args) 359 (if sly-symbol-completion-mode 360 (apply #'sly--completion-in-region-function args) 361 (apply oldfun args))) 362 '((name . sly--setup-completion)))) 363 364 (define-minor-mode sly-symbol-completion-mode "Fancy SLY UI for Lisp symbols" t 365 :global t) 366 367 (add-hook 'sly-mode-hook 'sly--setup-completion) 368 369 370 ;;; TODO: Most of the stuff emulates `completion--in-region' and its 371 ;;; callees in Emacs's minibuffer.el 372 ;;; 373 (defvar sly--completion-transient-data nil) ; similar to `completion-in-region--data' 374 375 (defvar sly--completion-transient-completions nil) ; not used 376 377 ;;; TODO: not tested with other functions in `completion-at-point-functions' 378 ;;; 379 (defun sly--completion-in-region-function (beg end function pred) 380 (cond 381 ((funcall function nil nil 'sly--identify) 382 (let* ((pattern (buffer-substring-no-properties beg end)) 383 (all 384 (all-completions pattern function pred)) 385 (try 386 (try-completion pattern function pred))) 387 (setq this-command 'completion-at-point) ; even if we started with `minibuffer-complete'! 388 (setq sly--completion-transient-completions all) 389 (cond ((eq try t) 390 ;; A unique completion 391 ;; 392 (choose-completion-string (cl-first all) 393 (current-buffer) 394 (list beg end)) 395 (sly-temp-message 0 2 "Sole completion")) 396 ;; Incomplete 397 ((stringp try) 398 (let ((pattern-overlay (make-overlay beg end nil nil nil))) 399 (setq sly--completion-transient-data 400 `(,pattern-overlay 401 ,function 402 ,pred)) 403 (overlay-put pattern-overlay 'face 'highlight) 404 (sly--completion-pop-up-completions-buffer pattern all) 405 (sly-temp-message 0 2 "Not unique") 406 (sly--completion-transient-mode 1))) 407 ((> (length pattern) 0) 408 (sly-temp-message 0 2 "No completions for %s" pattern))))) 409 (t 410 (funcall (default-value 'completion-in-region-function) 411 beg end function pred)))) 412 413 (defvar sly--completion-in-region-overlay 414 (let ((ov (make-overlay 0 0))) 415 (overlay-put ov 'face 'highlight) 416 (delete-overlay ov) 417 ov) 418 "Highlights the currently selected completion candidate") 419 420 (defvar sly--completion-display-mode-map 421 (let ((map (make-sparse-keymap))) 422 (define-key map [mouse-1] 'sly-choose-completion) 423 (define-key map [mouse-2] 'sly-choose-completion) 424 (define-key map [backtab] 'sly-prev-completion) 425 (define-key map (kbd "q") 'sly-completion-hide-completions) 426 (define-key map (kbd "C-g") 'sly-completion-hide-completions) 427 (define-key map (kbd "z") 'sly-completion-hide-completions) 428 (define-key map [remap previous-line] 'sly-prev-completion) 429 (define-key map [remap next-line] 'sly-next-completion) 430 (define-key map [left] 'sly-prev-completion) 431 (define-key map [right] 'sly-next-completion) 432 (define-key map (kbd "RET") 'sly-choose-completion) 433 map) 434 "Keymap used in the *sly-completions* buffer") 435 436 (define-derived-mode sly--completion-display-mode 437 fundamental-mode "SLY Completions" 438 "Major mode for presenting SLY completion results.") 439 440 (defun sly--completion-transient-mode-postch () 441 "Determine whether to pop down the *sly completions* buffer." 442 (unless (or unread-command-events ; Don't pop down the completions in the middle of 443 ; mouse-drag-region/mouse-set-point. 444 (let ((pattern-ov 445 (and sly--completion-transient-data 446 (car 447 sly--completion-transient-data)))) 448 (and pattern-ov 449 ;; check if we're in the same buffer 450 ;; 451 (eq (overlay-buffer pattern-ov) 452 (current-buffer)) 453 ;; check if point is somewhere acceptably related 454 ;; to the region data that originated the completion 455 ;; 456 (<= (overlay-start pattern-ov) 457 (point) 458 (overlay-end pattern-ov))))) 459 (sly--completion-transient-mode -1))) 460 461 (defvar sly--completion-transient-mode-map 462 (let ((map (make-sparse-keymap))) 463 (define-key map (kbd "C-n") 'sly-next-completion) 464 (define-key map (kbd "C-p") 'sly-prev-completion) 465 (define-key map (kbd "RET") 'sly-choose-completion) 466 (define-key map "\t" `(menu-item "" sly-choose-completion 467 :filter (lambda (original) 468 (when (memq last-command 469 '(completion-at-point 470 sly-next-completion 471 sly-prev-completion)) 472 original)))) 473 (define-key map (kbd "C-g") 'sly-quit-completing) 474 map) 475 "Keymap used in the buffer originating a *sly-completions* buffer") 476 477 (defvar sly--completion-transient-mode nil 478 "Explicit `defvar' for `sly--completion-transient-mode'") 479 480 (defun sly--completion-turn-off-transient-mode () 481 (if (eq major-mode 'sly--completion-display-mode) 482 (sly-message "Choosing completions directly in %s" (current-buffer)) 483 (sly-completion-hide-completions))) 484 485 (define-minor-mode sly--completion-transient-mode 486 "Minor mode when the \"*sly completions*\" buffer is showing" 487 ;; :lighter " SLY transient completing" 488 :variable sly--completion-transient-mode 489 :global t 490 (remove-hook 'post-command-hook #'sly--completion-transient-mode-postch) 491 (setq display-buffer-alist 492 (delq (assq 'sly--completion-transient-mode-display-guard-p display-buffer-alist) 493 display-buffer-alist)) 494 (setq minor-mode-overriding-map-alist 495 (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) 496 minor-mode-overriding-map-alist)) 497 (if (null sly--completion-transient-mode) 498 (sly--completion-turn-off-transient-mode) 499 (add-hook 'post-command-hook #'sly--completion-transient-mode-postch) 500 (push `(sly--completion-transient-mode . ,sly--completion-transient-mode-map) 501 minor-mode-overriding-map-alist) 502 (push `(sly--completion-transient-mode-display-guard-p 503 (sly--completion-transient-mode-teardown-before-displaying 504 . ,display-buffer-alist)) 505 display-buffer-alist))) 506 507 ;; `define-minor-mode' added to `minor-mode-map-alist', but we wanted 508 ;; `minor-mode-overriding-map-alist' instead, so undo changes to 509 ;; `minor-mode-map-alist' 510 ;; 511 (setq minor-mode-map-alist 512 (delq (assq 'sly--completion-transient-mode minor-mode-map-alist) 513 minor-mode-map-alist)) 514 515 ;; displaying other buffers with pop-to-buffer while in 516 ;; `sly--completion-transient-mode' is problematic, because it 517 ;; dedicates a window. Try some crazy `display-buffer-alist' shit to 518 ;; prevent that. 519 ;; 520 (defun sly--completion-transient-mode-display-guard-p (buffer-name _action) 521 (not (string-match-p "^*sly-completions*" buffer-name))) 522 523 (defun sly--completion-transient-mode-teardown-before-displaying (_buffer _alist) 524 (sly--completion-transient-mode -1) 525 ;; returns nil, hoping some other function in alist will display the 526 ;; buffer as intended. 527 nil) 528 529 (defun sly--completion-kill-transient-data () 530 (when (overlayp (car sly--completion-transient-data)) 531 (delete-overlay (car sly--completion-transient-data))) 532 (setq sly--completion-transient-data nil)) 533 534 (defun sly-completion-hide-completions () 535 (interactive) 536 (sly--completion-kill-transient-data) 537 (let* ((buffer (get-buffer (sly-buffer-name :completions))) 538 (win (and buffer 539 (get-buffer-window buffer 0)))) 540 (when win (with-selected-window win (quit-window t))))) 541 542 (defvar sly--completion-reference-buffer nil 543 "Like `completion-reference-buffer', which see") 544 545 (defmacro sly--completion-with-displayed-buffer-window (buffer 546 action 547 quit-function 548 &rest body) 549 ;;; WITH-DISPLAYED-BUFFER-WINDOW doesn't work noninteractively 550 (let ((original-sym (cl-gensym "original-buffer-"))) 551 `(if noninteractive 552 (let ((,original-sym (current-buffer))) 553 (display-buffer (get-buffer-create ,buffer) ,action) 554 (let ((standard-output ,buffer)) 555 (with-current-buffer ,original-sym 556 ,@body))) 557 (with-displayed-buffer-window ,buffer ,action ,quit-function 558 ,@body)))) 559 560 (defun sly--completion-pop-up-completions-buffer (_pattern completions) 561 (let ((display-buffer-mark-dedicated 'soft) 562 (pop-up-windows nil) 563 completions-buffer first-completion-point) 564 (sly--completion-with-displayed-buffer-window 565 (sly-buffer-name :completions) 566 `((display-buffer--maybe-same-window 567 display-buffer-reuse-window 568 display-buffer--maybe-pop-up-frame-or-window 569 ;; Use `display-buffer-below-selected' for inline completions, 570 ;; but not in the minibuffer (e.g. in `eval-expression') 571 ;; for which `display-buffer-at-bottom' is used. 572 ,(if (eq (selected-window) (minibuffer-window)) 573 'display-buffer-at-bottom 574 'display-buffer-below-selected)) 575 ,(if temp-buffer-resize-mode 576 '(window-height . resize-temp-buffer-window) 577 '(window-height . shrink-window-if-larger-than-buffer)) 578 ,(when temp-buffer-resize-mode 579 '(preserve-size . (nil . t)))) 580 nil 581 (sly--completion-transient-mode) 582 (let ((reference (current-buffer))) 583 (with-current-buffer standard-output 584 (sly--completion-display-mode) 585 (set (make-local-variable 'cursor-type) nil) 586 (setq sly--completion-reference-buffer reference) 587 (sly--completion-fill-completions-buffer completions) 588 (setq completions-buffer standard-output 589 first-completion-point (point)) 590 (add-hook 'kill-buffer-hook 'sly--completion-kill-transient-data t t)))) 591 (with-current-buffer completions-buffer 592 (goto-char first-completion-point)))) 593 594 (defvar sly--completion-explanation 595 (concat "Use \\[sly-next-completion] and \\[sly-prev-completion] to navigate completions." 596 " \\[sly-choose-completion] or [mouse-1] selects a completion." 597 "\n\nAnnotation flags: (b)oundp (f)boundp (g)eneric-function (c)lass (m)acro (s)pecial-operator\n\n")) 598 599 (defun sly--completion-fill-completions-buffer (completions) 600 (let ((inhibit-read-only t)) 601 (erase-buffer) 602 (insert (substitute-command-keys 603 sly--completion-explanation)) 604 (cl-loop with first = (point) 605 for completion in completions 606 for annotation = (or (get-text-property 0 'sly--annotation completion) 607 "") 608 for start = (point) 609 do 610 (cl-loop for (beg . end) in 611 (get-text-property 0 'sly-completion-chunks completion) 612 do (put-text-property beg 613 end 614 'face 615 'completions-common-part completion)) 616 (insert (propertize completion 617 'mouse-face 'highlight 618 'sly--completion t)) 619 (insert (make-string (max 620 1 621 (- (1- (window-width)) 622 (length completion) 623 (length annotation))) 624 ? ) 625 annotation) 626 (put-text-property start (point) 'sly--completion completion) 627 (insert "\n") 628 finally (goto-char first) (sly-next-completion 0)))) 629 630 (defun sly-next-completion (n &optional errorp) 631 (interactive "p") 632 (with-current-buffer (sly-buffer-name :completions) 633 (when (overlay-buffer sly--completion-in-region-overlay) 634 (goto-char (overlay-start sly--completion-in-region-overlay))) 635 (forward-line n) 636 (let* ((end (and (get-text-property (point) 'sly--completion) 637 (save-excursion 638 (skip-syntax-forward "^\s") 639 (point)) 640 ;; (next-single-char-property-change (point) 'sly--completion) 641 )) 642 (beg (and end 643 (previous-single-char-property-change end 'sly--completion)))) 644 (if (and beg end) 645 (progn 646 (move-overlay sly--completion-in-region-overlay 647 beg end) 648 (let ((win (get-buffer-window (current-buffer) 0))) 649 (when win 650 (with-selected-window win 651 (goto-char beg) 652 (sly-recenter beg))))) 653 (if errorp 654 (sly-error "No completion at point")))))) 655 656 (defun sly-prev-completion (n) 657 (interactive "p") 658 (sly-next-completion (- n))) 659 660 (defun sly-choose-completion (&optional event) 661 (interactive (list last-nonmenu-event)) 662 ;; In case this is run via the mouse, give temporary modes such as 663 ;; isearch a chance to turn off. 664 (run-hooks 'mouse-leave-buffer-hook) 665 (with-current-buffer (sly-buffer-name :completions) 666 (when event 667 (goto-char (posn-point (event-start event))) 668 (sly-next-completion 0 t)) 669 (let ((completion-text 670 (buffer-substring-no-properties (overlay-start sly--completion-in-region-overlay) 671 (overlay-end sly--completion-in-region-overlay)))) 672 (unless (buffer-live-p sly--completion-reference-buffer) 673 (sly-error "Destination buffer is dead")) 674 (choose-completion-string completion-text 675 sly--completion-reference-buffer 676 (let ((pattern-ov 677 (car sly--completion-transient-data))) 678 (list (overlay-start pattern-ov) 679 (overlay-end pattern-ov)))) 680 (sly--completion-transient-mode -1)))) 681 682 (defun sly-quit-completing () 683 (interactive) 684 (when sly--completion-transient-mode 685 (sly--completion-transient-mode -1)) 686 (keyboard-quit)) 687 688 689 690 ;;;; Minibuffer reading 691 692 (defvar sly-minibuffer-map 693 (let ((map (make-sparse-keymap))) 694 (set-keymap-parent map minibuffer-local-map) 695 (define-key map "\t" 'completion-at-point) 696 map) 697 "Minibuffer keymap used for reading CL expressions.") 698 699 700 (defvar sly-minibuffer-history '() 701 "History list of expressions read from the minibuffer.") 702 703 (defvar sly-minibuffer-symbol-history '() 704 "History list of symbols read from the minibuffer.") 705 706 (defmacro sly--with-sly-minibuffer (&rest body) 707 `(let* ((minibuffer-setup-hook 708 (cons (lambda () 709 (set-syntax-table lisp-mode-syntax-table) 710 (sly--setup-completion)) 711 minibuffer-setup-hook)) 712 (sly-buffer-package (sly-current-package)) 713 (sly-buffer-connection (sly-connection))) 714 ,@body)) 715 716 (defvar sly-minibuffer-setup-hook nil 717 "Setup SLY-specific minibuffer reads. 718 Used mostly (only?) by `sly-autodoc-mode'.") 719 720 (defun sly-read-from-minibuffer (prompt &optional initial-value history allow-empty keymap) 721 "Read a string from the minibuffer, prompting with PROMPT. 722 If INITIAL-VALUE is non-nil, it is inserted into the minibuffer 723 before reading input. The result is a string (\"\" if no input 724 was given and ALLOW-EMPTY is non-nil)." 725 (sly--with-sly-minibuffer 726 (cl-loop 727 with minibuffer-setup-hook = (cons 728 (lambda () 729 (run-hooks 'sly-minibuffer-setup-hook)) 730 minibuffer-setup-hook) 731 for i from 0 732 for read = (read-from-minibuffer 733 (concat "[sly] " (when (cl-plusp i) 734 "[can't be blank] ") 735 prompt) 736 (and (zerop i) 737 initial-value) 738 (or keymap sly-minibuffer-map) 739 nil (or history 'sly-minibuffer-history)) 740 when (or (> (length read) 0) 741 allow-empty) 742 return read))) 743 744 (defun sly-read-symbol-name (prompt &optional query) 745 "Either read a symbol name or choose the one at point. 746 The user is prompted if a prefix argument is in effect, if there is no 747 symbol at point, or if QUERY is non-nil." 748 (let* ((sym-at-point (sly-symbol-at-point)) 749 (completion-category-overrides 750 (cons '(sly-completion (styles . (backend))) 751 completion-category-overrides)) 752 (wrapper (sly--completion-function-wrapper sly-complete-symbol-function)) 753 (do-it (lambda () (completing-read prompt wrapper nil nil sym-at-point)))) 754 (cond ((or current-prefix-arg query (not sym-at-point)) 755 (cond (sly-symbol-completion-mode 756 (let ((icomplete-mode nil) 757 (completing-read-function #'completing-read-default)) 758 (sly--with-sly-minibuffer (funcall do-it)))) 759 (t (funcall do-it)))) 760 (t sym-at-point)))) 761 762 (provide 'sly-completion) 763 ;;; sly-completion.el ends here 764