sly-completion.el (31941B)
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 (when (sly-connected-p) 165 (let* ((sly-current-thread t)) 166 (sly--responsive-eval 167 (completions `(,slyfun ,(substring-no-properties pattern) 168 ',(sly-current-package))) 169 completions)))) 170 171 (defun sly-simple-completions (prefix) 172 "Return (COMPLETIONS COMMON) where COMPLETIONS complete the PREFIX. 173 COMPLETIONS is a list of propertized strings. 174 COMMON a string, the common prefix." 175 (cl-loop with first-difference-pos = (length prefix) 176 with (completions common) = 177 (sly--completion-request-completions prefix 'slynk-completion:simple-completions) 178 for completion in completions 179 do (put-text-property first-difference-pos 180 (min (1+ first-difference-pos) 181 (1- (length completion))) 182 'face 183 'completions-first-difference 184 completion) 185 collect completion into formatted 186 finally return (list formatted common))) 187 188 (defun sly-flex-completions (pattern) 189 "Return (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. 190 COMPLETIONS is a list of propertized strings." 191 (cl-loop with (completions _) = 192 (sly--completion-request-completions pattern 'slynk-completion:flex-completions) 193 for (completion score chunks classification suggestion) in completions 194 do 195 (cl-loop for (pos substring) in chunks 196 do (put-text-property pos (+ pos 197 (length substring)) 198 'face 199 'completions-first-difference 200 completion) 201 collect `(,pos . ,(+ pos (length substring))) into chunks-2 202 finally (put-text-property 0 (length completion) 203 'sly-completion-chunks chunks-2 204 completion)) 205 (add-text-properties 0 206 (length completion) 207 `(sly--annotation 208 ,(format "%s %5.2f%%" 209 classification 210 (* score 100)) 211 sly--suggestion 212 ,suggestion) 213 completion) 214 215 collect completion into formatted 216 finally return (list formatted nil))) 217 218 (defun sly-completion-annotation (completion) 219 "Grab the annotation of COMPLETION, a string, if any" 220 (get-text-property 0 'sly--annotation completion)) 221 222 ;;; backward-compatibility 223 (defun sly-fuzzy-completions (pattern) 224 "This function is obsolete since 1.0.0-beta-2; 225 use ‘sly-flex-completions’ instead, but notice the updated protocol. 226 227 Returns (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. 228 229 COMPLETIONS is a list of elements of the form (STRING NIL NIL 230 ANNOTATION) describing each completion possibility." 231 (let ((new (sly-flex-completions pattern))) 232 (list (mapcar (lambda (string) 233 (list string nil nil (sly-completion-annotation string))) 234 (car new)) 235 (cadr new)))) 236 237 (when (boundp 'completion-category-overrides) 238 (add-to-list 'completion-category-overrides 239 '(sly-completion (styles . (backend))))) 240 241 (defun sly--completion-function-wrapper (fn) 242 (let ((cache (make-hash-table :test #'equal))) 243 (lambda (string pred action) 244 (cl-labels ((all 245 () 246 (let ((probe (gethash string cache :missing))) 247 (if (eq probe :missing) 248 (puthash string (funcall fn string) cache) 249 probe))) 250 (try () 251 (let ((all (all))) 252 (and (car all) 253 (if (and (null (cdr (car all))) 254 (string= string (caar all))) 255 t 256 string))))) 257 (pcase action 258 ;; identify this to the custom `sly--completion-in-region-function' 259 (`sly--identify t) 260 ;; identify this to other UI's 261 (`metadata '(metadata 262 (display-sort-function . identity) 263 (category . sly-completion))) 264 ;; all completions 265 (`t (car (all))) 266 ;; try completion 267 (`nil (try)) 268 (`(try-completion . ,point) 269 (cons 'try-completion (cons string point))) 270 (`(all-completions . ,_point) (cons 'all-completions (car (all)))) 271 (`(boundaries . ,thing) 272 (completion-boundaries string (all) pred thing)) 273 274 ;; boundaries or any other value 275 (_ nil)))))) 276 277 ;; This duplicates a function in sly-parse.el 278 (defun sly--completion-inside-string-or-comment-p () 279 (let ((ppss (syntax-ppss))) (or (nth 3 ppss) (nth 4 ppss)))) 280 281 (defun sly--completions-complete-symbol-1 (fn) 282 (let* ((beg (sly-symbol-start-pos)) 283 (end (sly-symbol-end-pos))) 284 (list beg end 285 (sly--completion-function-wrapper fn) 286 :annotation-function #'sly-completion-annotation 287 :exit-function (lambda (obj _status) 288 (let ((suggestion 289 (get-text-property 0 'sly--suggestion 290 obj))) 291 (when suggestion 292 (delete-region (- (point) (length obj)) (point)) 293 (insert suggestion)))) 294 :company-docsig 295 (lambda (obj) 296 (when (sit-for 0.1) 297 (sly--responsive-eval (arglist `(slynk:operator-arglist 298 ,(substring-no-properties obj) 299 ,(sly-current-package))) 300 (or (and arglist 301 (sly-autodoc--fontify arglist)) 302 "no autodoc information")))) 303 :company-no-cache t 304 :company-doc-buffer 305 (lambda (obj) 306 (when (sit-for 0.1) 307 (sly--responsive-eval (doc `(slynk:describe-symbol 308 ,(substring-no-properties obj))) 309 (when doc 310 (with-current-buffer (get-buffer-create " *sly-completion doc*") 311 (erase-buffer) 312 (insert doc) 313 (current-buffer)))))) 314 :company-require-match 'never 315 :company-match 316 (lambda (obj) 317 (get-text-property 0 'sly-completion-chunks obj)) 318 :company-location 319 (lambda (obj) 320 (save-window-excursion 321 (let* ((buffer (sly-edit-definition 322 (substring-no-properties obj)))) 323 (when (buffer-live-p buffer) ; on the safe side 324 (cons buffer (with-current-buffer buffer 325 (point))))))) 326 :company-prefix-length 327 (and (sly--completion-inside-string-or-comment-p) 0)))) 328 329 (defun sly-simple-complete-symbol () 330 "Prefix completion on the symbol at point. 331 Intended to go into `completion-at-point-functions'" 332 (sly--completions-complete-symbol-1 'sly-simple-completions)) 333 334 (defun sly-flex-complete-symbol () 335 "\"Flex\" completion on the symbol at point. 336 Intended to go into `completion-at-point-functions'" 337 (sly--completions-complete-symbol-1 'sly-flex-completions)) 338 339 (defun sly-complete-symbol () 340 "Completion on the symbol at point, using `sly-complete-symbol-function' 341 Intended to go into `completion-at-point-functions'" 342 (sly--completions-complete-symbol-1 sly-complete-symbol-function)) 343 344 (defun sly-complete-filename-maybe () 345 (when (nth 3 (syntax-ppss)) (comint-filename-completion))) 346 347 348 ;;; Set `completion-at-point-functions' and a few other tricks 349 ;;; 350 (defun sly--setup-completion () 351 ;; This one can be customized by a SLY user in `sly-mode-hook' 352 ;; 353 (setq-local completion-at-point-functions '(sly-complete-filename-maybe 354 sly-complete-symbol)) 355 (add-function :around (local 'completion-in-region-function) 356 (lambda (oldfun &rest args) 357 (if sly-symbol-completion-mode 358 (apply #'sly--completion-in-region-function args) 359 (apply oldfun args))) 360 '((name . sly--setup-completion)))) 361 362 (define-minor-mode sly-symbol-completion-mode "Fancy SLY UI for Lisp symbols" t 363 :global t) 364 365 (add-hook 'sly-mode-hook 'sly--setup-completion) 366 367 368 ;;; TODO: Most of the stuff emulates `completion--in-region' and its 369 ;;; callees in Emacs's minibuffer.el 370 ;;; 371 (defvar sly--completion-transient-data nil) ; similar to `completion-in-region--data' 372 373 (defvar sly--completion-transient-completions nil) ; not used 374 375 ;;; TODO: not tested with other functions in `completion-at-point-functions' 376 ;;; 377 (defun sly--completion-in-region-function (beg end function pred) 378 (cond 379 ((funcall function nil nil 'sly--identify) 380 (let* ((pattern (buffer-substring-no-properties beg end)) 381 (all 382 (all-completions pattern function pred)) 383 (try 384 (try-completion pattern function pred))) 385 (setq this-command 'completion-at-point) ; even if we started with `minibuffer-complete'! 386 (setq sly--completion-transient-completions all) 387 (cond ((eq try t) 388 ;; A unique completion 389 ;; 390 (choose-completion-string (cl-first all) 391 (current-buffer) 392 (list beg end)) 393 (sly-temp-message 0 2 "Sole completion")) 394 ;; Incomplete 395 ((stringp try) 396 (let ((pattern-overlay (make-overlay beg end nil nil nil))) 397 (setq sly--completion-transient-data 398 `(,pattern-overlay 399 ,function 400 ,pred)) 401 (overlay-put pattern-overlay 'face 'highlight) 402 (sly--completion-pop-up-completions-buffer pattern all) 403 (sly-temp-message 0 2 "Not unique") 404 (sly--completion-transient-mode 1))) 405 ((> (length pattern) 0) 406 (sly-temp-message 0 2 "No completions for %s" pattern))))) 407 (t 408 (funcall (default-value 'completion-in-region-function) 409 beg end function pred)))) 410 411 (defvar sly--completion-in-region-overlay 412 (let ((ov (make-overlay 0 0))) 413 (overlay-put ov 'face 'highlight) 414 (delete-overlay ov) 415 ov) 416 "Highlights the currently selected completion candidate") 417 418 (defvar sly--completion-display-mode-map 419 (let ((map (make-sparse-keymap))) 420 (define-key map [mouse-1] 'sly-choose-completion) 421 (define-key map [mouse-2] 'sly-choose-completion) 422 (define-key map [backtab] 'sly-prev-completion) 423 (define-key map (kbd "q") 'sly-completion-hide-completions) 424 (define-key map (kbd "C-g") 'sly-completion-hide-completions) 425 (define-key map (kbd "z") 'sly-completion-hide-completions) 426 (define-key map [remap previous-line] 'sly-prev-completion) 427 (define-key map [remap next-line] 'sly-next-completion) 428 (define-key map [left] 'sly-prev-completion) 429 (define-key map [right] 'sly-next-completion) 430 (define-key map (kbd "RET") 'sly-choose-completion) 431 map) 432 "Keymap used in the *sly-completions* buffer") 433 434 (define-derived-mode sly--completion-display-mode 435 fundamental-mode "SLY Completions" 436 "Major mode for presenting SLY completion results.") 437 438 (defun sly--completion-transient-mode-postch () 439 "Determine whether to pop down the *sly completions* buffer." 440 (unless (or unread-command-events ; Don't pop down the completions in the middle of 441 ; mouse-drag-region/mouse-set-point. 442 (let ((pattern-ov 443 (and sly--completion-transient-data 444 (car 445 sly--completion-transient-data)))) 446 (and pattern-ov 447 ;; check if we're in the same buffer 448 ;; 449 (eq (overlay-buffer pattern-ov) 450 (current-buffer)) 451 ;; check if point is somewhere acceptably related 452 ;; to the region data that originated the completion 453 ;; 454 (<= (overlay-start pattern-ov) 455 (point) 456 (overlay-end pattern-ov))))) 457 (sly--completion-transient-mode -1))) 458 459 (defvar sly--completion-transient-mode-map 460 (let ((map (make-sparse-keymap))) 461 (define-key map (kbd "C-n") 'sly-next-completion) 462 (define-key map (kbd "C-p") 'sly-prev-completion) 463 (define-key map (kbd "RET") 'sly-choose-completion) 464 (define-key map "\t" `(menu-item "" sly-choose-completion 465 :filter (lambda (original) 466 (when (memq last-command 467 '(completion-at-point 468 sly-next-completion 469 sly-prev-completion)) 470 original)))) 471 (define-key map (kbd "C-g") 'sly-quit-completing) 472 map) 473 "Keymap used in the buffer originating a *sly-completions* buffer") 474 475 (defvar sly--completion-transient-mode nil 476 "Explicit `defvar' for `sly--completion-transient-mode'") 477 478 (defun sly--completion-turn-off-transient-mode () 479 (if (eq major-mode 'sly--completion-display-mode) 480 (sly-message "Choosing completions directly in %s" (current-buffer)) 481 (sly-completion-hide-completions))) 482 483 (define-minor-mode sly--completion-transient-mode 484 "Minor mode when the \"*sly completions*\" buffer is showing" 485 ;; :lighter " SLY transient completing" 486 :variable sly--completion-transient-mode 487 :global t 488 (remove-hook 'post-command-hook #'sly--completion-transient-mode-postch) 489 (setq display-buffer-alist 490 (delq (assq 'sly--completion-transient-mode-display-guard-p display-buffer-alist) 491 display-buffer-alist)) 492 (setq minor-mode-overriding-map-alist 493 (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) 494 minor-mode-overriding-map-alist)) 495 (if (null sly--completion-transient-mode) 496 (sly--completion-turn-off-transient-mode) 497 (add-hook 'post-command-hook #'sly--completion-transient-mode-postch) 498 (push `(sly--completion-transient-mode . ,sly--completion-transient-mode-map) 499 minor-mode-overriding-map-alist) 500 (push `(sly--completion-transient-mode-display-guard-p 501 (sly--completion-transient-mode-teardown-before-displaying 502 . ,display-buffer-alist)) 503 display-buffer-alist))) 504 505 ;; `define-minor-mode' added to `minor-mode-map-alist', but we wanted 506 ;; `minor-mode-overriding-map-alist' instead, so undo changes to 507 ;; `minor-mode-map-alist' 508 ;; 509 (setq minor-mode-map-alist 510 (delq (assq 'sly--completion-transient-mode minor-mode-map-alist) 511 minor-mode-map-alist)) 512 513 ;; displaying other buffers with pop-to-buffer while in 514 ;; `sly--completion-transient-mode' is problematic, because it 515 ;; dedicates a window. Try some crazy `display-buffer-alist' shit to 516 ;; prevent that. 517 ;; 518 (defun sly--completion-transient-mode-display-guard-p (buffer-name _action) 519 (not (string-match-p "^*sly-completions*" buffer-name))) 520 521 (defun sly--completion-transient-mode-teardown-before-displaying (_buffer _alist) 522 (sly--completion-transient-mode -1) 523 ;; returns nil, hoping some other function in alist will display the 524 ;; buffer as intended. 525 nil) 526 527 (defun sly--completion-kill-transient-data () 528 (when (overlayp (car sly--completion-transient-data)) 529 (delete-overlay (car sly--completion-transient-data))) 530 (setq sly--completion-transient-data nil)) 531 532 (defun sly-completion-hide-completions () 533 (interactive) 534 (sly--completion-kill-transient-data) 535 (let* ((buffer (get-buffer (sly-buffer-name :completions))) 536 (win (and buffer 537 (get-buffer-window buffer 0)))) 538 (when win (with-selected-window win (quit-window t))))) 539 540 (defvar sly--completion-reference-buffer nil 541 "Like `completion-reference-buffer', which see") 542 543 (defmacro sly--completion-with-displayed-buffer-window (buffer 544 action 545 quit-function 546 &rest body) 547 ;;; WITH-DISPLAYED-BUFFER-WINDOW doesn't work noninteractively 548 (let ((original-sym (cl-gensym "original-buffer-"))) 549 `(if noninteractive 550 (let ((,original-sym (current-buffer))) 551 (display-buffer (get-buffer-create ,buffer) ,action) 552 (let ((standard-output ,buffer)) 553 (with-current-buffer ,original-sym 554 ,@body))) 555 (with-displayed-buffer-window ,buffer ,action ,quit-function 556 ,@body)))) 557 558 (defun sly--completion-pop-up-completions-buffer (_pattern completions) 559 (let ((display-buffer-mark-dedicated 'soft) 560 (pop-up-windows nil) 561 completions-buffer first-completion-point) 562 (sly--completion-with-displayed-buffer-window 563 (sly-buffer-name :completions) 564 `((display-buffer--maybe-same-window 565 display-buffer-reuse-window 566 display-buffer--maybe-pop-up-frame-or-window 567 ;; Use `display-buffer-below-selected' for inline completions, 568 ;; but not in the minibuffer (e.g. in `eval-expression') 569 ;; for which `display-buffer-at-bottom' is used. 570 ,(if (eq (selected-window) (minibuffer-window)) 571 'display-buffer-at-bottom 572 'display-buffer-below-selected)) 573 ,(if temp-buffer-resize-mode 574 '(window-height . resize-temp-buffer-window) 575 '(window-height . shrink-window-if-larger-than-buffer)) 576 ,(when temp-buffer-resize-mode 577 '(preserve-size . (nil . t)))) 578 nil 579 (sly--completion-transient-mode) 580 (let ((reference (current-buffer))) 581 (with-current-buffer standard-output 582 (sly--completion-display-mode) 583 (set (make-local-variable 'cursor-type) nil) 584 (setq sly--completion-reference-buffer reference) 585 (sly--completion-fill-completions-buffer completions) 586 (setq completions-buffer standard-output 587 first-completion-point (point)) 588 (add-hook 'kill-buffer-hook 'sly--completion-kill-transient-data t t)))) 589 (with-current-buffer completions-buffer 590 (goto-char first-completion-point)))) 591 592 (defvar sly--completion-explanation 593 (concat "Use \\[sly-next-completion] and \\[sly-prev-completion] to navigate completions." 594 " \\[sly-choose-completion] or [mouse-1] selects a completion." 595 "\n\nAnnotation flags: (b)oundp (f)boundp (g)eneric-function (c)lass (m)acro (s)pecial-operator\n\n")) 596 597 (defun sly--completion-fill-completions-buffer (completions) 598 (let ((inhibit-read-only t)) 599 (erase-buffer) 600 (insert (substitute-command-keys 601 sly--completion-explanation)) 602 (cl-loop with first = (point) 603 for completion in completions 604 for annotation = (or (get-text-property 0 'sly--annotation completion) 605 "") 606 for start = (point) 607 do 608 (cl-loop for (beg . end) in 609 (get-text-property 0 'sly-completion-chunks completion) 610 do (put-text-property beg 611 end 612 'face 613 'completions-common-part completion)) 614 (insert (propertize completion 615 'mouse-face 'highlight 616 'sly--completion t)) 617 (insert (make-string (max 618 1 619 (- (1- (window-width)) 620 (length completion) 621 (length annotation))) 622 ? ) 623 annotation) 624 (put-text-property start (point) 'sly--completion completion) 625 (insert "\n") 626 finally (goto-char first) (sly-next-completion 0)))) 627 628 (defun sly-next-completion (n &optional errorp) 629 (interactive "p") 630 (with-current-buffer (sly-buffer-name :completions) 631 (when (overlay-buffer sly--completion-in-region-overlay) 632 (goto-char (overlay-start sly--completion-in-region-overlay))) 633 (forward-line n) 634 (let* ((end (and (get-text-property (point) 'sly--completion) 635 (save-excursion 636 (skip-syntax-forward "^\s") 637 (point)) 638 ;; (next-single-char-property-change (point) 'sly--completion) 639 )) 640 (beg (and end 641 (previous-single-char-property-change end 'sly--completion)))) 642 (if (and beg end) 643 (progn 644 (move-overlay sly--completion-in-region-overlay 645 beg end) 646 (let ((win (get-buffer-window (current-buffer) 0))) 647 (when win 648 (with-selected-window win 649 (goto-char beg) 650 (sly-recenter beg))))) 651 (if errorp 652 (sly-error "No completion at point")))))) 653 654 (defun sly-prev-completion (n) 655 (interactive "p") 656 (sly-next-completion (- n))) 657 658 (defun sly-choose-completion (&optional event) 659 (interactive (list last-nonmenu-event)) 660 ;; In case this is run via the mouse, give temporary modes such as 661 ;; isearch a chance to turn off. 662 (run-hooks 'mouse-leave-buffer-hook) 663 (with-current-buffer (sly-buffer-name :completions) 664 (when event 665 (goto-char (posn-point (event-start event))) 666 (sly-next-completion 0 t)) 667 (let ((completion-text 668 (buffer-substring-no-properties (overlay-start sly--completion-in-region-overlay) 669 (overlay-end sly--completion-in-region-overlay)))) 670 (unless (buffer-live-p sly--completion-reference-buffer) 671 (sly-error "Destination buffer is dead")) 672 (choose-completion-string completion-text 673 sly--completion-reference-buffer 674 (let ((pattern-ov 675 (car sly--completion-transient-data))) 676 (list (overlay-start pattern-ov) 677 (overlay-end pattern-ov)))) 678 (sly--completion-transient-mode -1)))) 679 680 (defun sly-quit-completing () 681 (interactive) 682 (when sly--completion-transient-mode 683 (sly--completion-transient-mode -1)) 684 (keyboard-quit)) 685 686 687 688 ;;;; Minibuffer reading 689 690 (defvar sly-minibuffer-map 691 (let ((map (make-sparse-keymap))) 692 (set-keymap-parent map minibuffer-local-map) 693 (define-key map "\t" 'completion-at-point) 694 map) 695 "Minibuffer keymap used for reading CL expressions.") 696 697 698 (defvar sly-minibuffer-history '() 699 "History list of expressions read from the minibuffer.") 700 701 (defvar sly-minibuffer-symbol-history '() 702 "History list of symbols read from the minibuffer.") 703 704 (defmacro sly--with-sly-minibuffer (&rest body) 705 `(let* ((minibuffer-setup-hook 706 (cons (lambda () 707 (set-syntax-table lisp-mode-syntax-table) 708 (sly--setup-completion)) 709 minibuffer-setup-hook)) 710 (sly-buffer-package (sly-current-package)) 711 (sly-buffer-connection (sly-connection))) 712 ,@body)) 713 714 (defvar sly-minibuffer-setup-hook nil 715 "Setup SLY-specific minibuffer reads. 716 Used mostly (only?) by `sly-autodoc-mode'.") 717 718 (defun sly-read-from-minibuffer (prompt &optional initial-value history allow-empty keymap) 719 "Read a string from the minibuffer, prompting with PROMPT. 720 If INITIAL-VALUE is non-nil, it is inserted into the minibuffer 721 before reading input. The result is a string (\"\" if no input 722 was given and ALLOW-EMPTY is non-nil)." 723 (sly--with-sly-minibuffer 724 (cl-loop 725 with minibuffer-setup-hook = (cons 726 (lambda () 727 (run-hooks 'sly-minibuffer-setup-hook)) 728 minibuffer-setup-hook) 729 for i from 0 730 for read = (read-from-minibuffer 731 (concat "[sly] " (when (cl-plusp i) 732 "[can't be blank] ") 733 prompt) 734 (and (zerop i) 735 initial-value) 736 (or keymap sly-minibuffer-map) 737 nil (or history 'sly-minibuffer-history)) 738 when (or (> (length read) 0) 739 allow-empty) 740 return read))) 741 742 (defun sly-read-symbol-name (prompt &optional query) 743 "Either read a symbol name or choose the one at point. 744 The user is prompted if a prefix argument is in effect, if there is no 745 symbol at point, or if QUERY is non-nil." 746 (let* ((sym-at-point (sly-symbol-at-point)) 747 (completion-category-overrides 748 (cons '(sly-completion (styles . (backend))) 749 completion-category-overrides)) 750 (wrapper (sly--completion-function-wrapper sly-complete-symbol-function)) 751 (do-it (lambda () (completing-read prompt wrapper nil nil sym-at-point)))) 752 (cond ((or current-prefix-arg query (not sym-at-point)) 753 (cond (sly-symbol-completion-mode 754 (let ((icomplete-mode nil) 755 (completing-read-function #'completing-read-default)) 756 (sly--with-sly-minibuffer (funcall do-it)))) 757 (t (funcall do-it)))) 758 (t sym-at-point)))) 759 760 (provide 'sly-completion) 761 ;;; sly-completion.el ends here 762