sly-mrepl.el (62332B)
1 ;; -*- lexical-binding: t -*- An experimental implementation of 2 ;; multiple REPLs multiplexed over a single Slime socket. M-x 3 ;; sly-mrepl or M-x sly-mrepl-new create new REPL buffers. 4 ;; 5 (require 'sly) 6 (require 'sly-autodoc) 7 (require 'cl-lib) 8 (require 'comint) 9 10 (define-sly-contrib sly-mrepl 11 "Multiple REPLs." 12 (:license "GPL") 13 (:sly-dependencies sly-autodoc) 14 (:slynk-dependencies slynk/mrepl) 15 (:on-load 16 ;; Define a new "part action" for the `sly-part' buttons and change 17 ;; the `sly-inspector-part', `sly-db-local-variable' and 18 ;; `sly-trace-dialog-part' to include it. 19 ;; 20 (sly-button-define-part-action sly-mrepl-copy-part-to-repl 21 "Copy to REPL" (kbd "M-RET")) 22 (sly-button-define-part-action sly-mrepl-copy-call-to-repl 23 "Copy call to REPL" (kbd "M-S-<return>")) 24 (button-type-put 'sly-inspector-part 25 'sly-mrepl-copy-part-to-repl 26 'sly-inspector-copy-part-to-repl) 27 (button-type-put 'sly-db-local-variable 28 'sly-mrepl-copy-part-to-repl 29 'sly-db-copy-part-to-repl) 30 (button-type-put 'sly-apropos-symbol 31 'sly-mrepl-copy-part-to-repl 32 'sly-apropos-copy-symbol-to-repl) 33 (button-type-put 'sly-db-frame 34 'sly-mrepl-copy-call-to-repl 35 'sly-db-copy-call-to-repl) 36 (eval-after-load "sly-trace-dialog" 37 `(progn 38 (button-type-put 'sly-trace-dialog-part 39 'sly-mrepl-copy-part-to-repl 40 'sly-trace-dialog-copy-part-to-repl) 41 (button-type-put 'sly-trace-dialog-spec 42 'sly-mrepl-copy-call-to-repl 43 'sly-trace-dialog-copy-call-to-repl))) 44 ;; Make C-c ~ bring popup REPL 45 ;; 46 (define-key sly-mode-map (kbd "C-c ~") 'sly-mrepl-sync) 47 (define-key sly-mode-map (kbd "C-c C-z") 'sly-mrepl) 48 (define-key sly-selector-map (kbd "~") 'sly-mrepl-sync) 49 (define-key sly-selector-map (kbd "r") 'sly-mrepl) 50 51 ;; Insinuate ourselves in hooks 52 ;; 53 (add-hook 'sly-connected-hook 'sly-mrepl-on-connection) 54 (add-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls) 55 ;; The connection list is also tweaked 56 ;; 57 (setq sly-connection-list-button-action 58 #'(lambda (process) 59 (let ((sly-default-connection process)) 60 (sly-mrepl 'pop-to-buffer))))) 61 (:on-unload 62 ;; FIXME: This `:on-unload' is grossly incomplete 63 ;; 64 (remove-hook 'sly-connected-hook 'sly-mrepl-on-connection) 65 (remove-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls))) 66 67 68 ;; User-visible variables 69 ;; 70 (defvar sly-mrepl-mode-hook nil 71 "Functions run after `sly-mrepl-mode' is set up") 72 73 (defvar sly-mrepl-hook nil 74 "Functions run after `sly-mrepl-new' sets up a REPL.") 75 76 (defvar sly-mrepl-runonce-hook nil 77 "Functions run once after `sly-mrepl-new' sets up a REPL. 78 79 After running the contents of this hook its default value is 80 emptied. See also `sly-mrepl-hook'") 81 82 (defvar sly-mrepl-output-filter-functions comint-preoutput-filter-functions 83 "List of functions filtering Slynk's REPL output. 84 This variables behaves like `comint-preoutput-filter-functions', 85 for output printed to the REPL (not for evaluation results)") 86 87 (defvar sly-mrepl-mode-map 88 (let ((map (make-sparse-keymap))) 89 (define-key map (kbd "RET") 'sly-mrepl-return) 90 (define-key map (kbd "TAB") 'sly-mrepl-indent-and-complete-symbol) 91 (define-key map (kbd "C-c C-b") 'sly-interrupt) 92 (define-key map (kbd "C-c C-c") 'sly-interrupt) 93 (define-key map (kbd "C-c C-o") 'sly-mrepl-clear-recent-output) 94 (define-key map (kbd "C-c M-o") 'sly-mrepl-clear-repl) 95 (define-key map (kbd "M-p") 'sly-mrepl-previous-input-or-button) 96 (define-key map (kbd "M-n") 'sly-mrepl-next-input-or-button) 97 (define-key map (kbd "C-M-p") 'sly-button-backward) 98 (define-key map (kbd "C-M-n") 'sly-button-forward) 99 map)) 100 101 (defvar sly-mrepl-pop-sylvester 'on-connection) 102 103 (defface sly-mrepl-prompt-face 104 `((t (:inherit font-lock-builtin-face))) 105 "Face for the regular MREPL prompt." 106 :group 'sly-mode-faces) 107 108 (defface sly-mrepl-note-face 109 `((t (:inherit font-lock-keyword-face))) 110 "Face for the MREPL notes." 111 :group 'sly-mode-faces) 112 113 (defface sly-mrepl-output-face 114 '((((class color) 115 (background dark)) 116 (:foreground "VioletRed1")) 117 (((class color) 118 (background light)) 119 (:foreground "steel blue")) 120 (t 121 (:bold t :italic t))) 122 "Face for the regular MREPL prompt." 123 :group 'sly-mode-faces) 124 125 126 ;; Internal variables 127 ;; 128 (defvar sly-mrepl--remote-channel nil) 129 (defvar sly-mrepl--local-channel nil) 130 (defvar sly-mrepl--read-mark nil) 131 (defvar sly-mrepl--output-mark nil) 132 (defvar sly-mrepl--dedicated-stream nil) 133 (defvar sly-mrepl--last-prompt-overlay nil) 134 (defvar sly-mrepl--pending-output nil 135 "Output that can't be inserted right now.") 136 (defvar sly-mrepl--dedicated-stream-hooks) 137 (defvar sly-mrepl--history-separator "####\n") 138 (defvar sly-mrepl--dirty-history nil) 139 140 141 ;; Major mode 142 ;; 143 (define-derived-mode sly-mrepl-mode comint-mode "mrepl" 144 (sly-mode 1) 145 (cl-loop for (var value) 146 in `((comint-use-prompt-regexp nil) 147 (comint-inhibit-carriage-motion t) 148 (comint-input-sender sly-mrepl--input-sender) 149 (comint-output-filter-functions nil) 150 (comint-input-filter-functions nil) 151 (comint-history-isearch dwim) 152 (comint-input-ignoredups t) 153 (comint-prompt-read-only t) 154 (comint-process-echoes nil) 155 (indent-line-function lisp-indent-line) 156 (sly-mrepl--read-mark nil) 157 (sly-mrepl--pending-output nil) 158 (sly-mrepl--output-mark ,(point-marker)) 159 (sly-mrepl--last-prompt-overlay ,(make-overlay 0 0 nil nil)) 160 (sly-find-buffer-package-function sly-mrepl-guess-package) 161 (sly-autodoc-inhibit-autodoc 162 sly-mrepl-inside-string-or-comment-p) 163 (mode-line-process nil) 164 (parse-sexp-ignore-comments t) 165 (syntax-propertize-function sly-mrepl--syntax-propertize) 166 (forward-sexp-function sly-mrepl--forward-sexp) 167 (comint-scroll-show-maximum-output nil) 168 (comint-scroll-to-bottom-on-input nil) 169 (comint-scroll-to-bottom-on-output nil) 170 (inhibit-field-text-motion nil) 171 (lisp-indent-function sly-common-lisp-indent-function) 172 (open-paren-in-column-0-is-defun-start nil) 173 (buffer-file-coding-system utf-8-unix) 174 ;; Paredit workaround (see 175 ;; https://github.com/joaotavora/sly/issues/110) 176 (paredit-override-check-parens-function (lambda (_c) t)) 177 (comment-start ";")) 178 do (set (make-local-variable var) value)) 179 (set-marker-insertion-type sly-mrepl--output-mark nil) 180 (add-hook 'kill-emacs-hook 'sly-mrepl--save-all-histories) 181 ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input) 182 (set-syntax-table lisp-mode-syntax-table) 183 (set-keymap-parent sly-mrepl-mode-map nil) 184 185 ;; The REPL buffer has interactive text buttons 186 (sly-interactive-buttons-mode 1) 187 188 ;; Add hooks to isearch-mode placed strategically after the ones 189 ;; set by comint.el itself. 190 ;; 191 (add-hook 'isearch-mode-hook 'sly-mrepl--setup-comint-isearch t t) 192 (add-hook 'isearch-mode-end-hook 'sly-mrepl--teardown-comint-isearch t t) 193 194 ;; Add a post-command-handler 195 ;; 196 (add-hook 'post-command-hook 'sly-mrepl--highlight-backreferences-maybe t t)) 197 198 199 ;;; Channel methods 200 (sly-define-channel-type listener) 201 202 (sly-define-channel-method listener :write-values (results) 203 (with-current-buffer (sly-channel-get self 'buffer) 204 (sly-mrepl--insert-results results))) 205 206 (sly-define-channel-method listener :evaluation-aborted (&optional condition) 207 (with-current-buffer (sly-channel-get self 'buffer) 208 (sly-mrepl--catch-up) 209 (sly-mrepl--insert-note (format "Evaluation aborted on %s" condition)))) 210 211 (sly-define-channel-method listener :write-string (string) 212 (with-current-buffer (sly-channel-get self 'buffer) 213 (sly-mrepl--insert-output string))) 214 215 (sly-define-channel-method listener :set-read-mode (mode) 216 (with-current-buffer (sly-channel-get self 'buffer) 217 (cl-macrolet ((assert-soft 218 (what) `(unless ,what 219 (sly-warning 220 ,(format "Expectation failed: %s" what))))) 221 (let ((inhibit-read-only t)) 222 (cl-ecase mode 223 (:read 224 (assert-soft (null sly-mrepl--read-mark)) 225 ;; Give a chance for output to come in before we block it 226 ;; during the read. 227 (sly-mrepl--accept-process-output) 228 (setq sly-mrepl--read-mark (point)) 229 (add-text-properties (1- (point)) (point) 230 `(rear-nonsticky t)) 231 (sly-message "REPL now waiting for input to read")) 232 (:finished-reading 233 (assert-soft (integer-or-marker-p sly-mrepl--read-mark)) 234 (when sly-mrepl--read-mark 235 (add-text-properties (1- sly-mrepl--read-mark) (point) 236 `(face bold read-only t))) 237 (setq sly-mrepl--read-mark nil) 238 (sly-message "REPL back to normal evaluation mode"))))))) 239 240 (sly-define-channel-method listener :prompt (package prompt 241 error-level 242 &optional condition) 243 (with-current-buffer (sly-channel-get self 'buffer) 244 (sly-mrepl--insert-prompt package prompt error-level condition))) 245 246 (sly-define-channel-method listener :open-dedicated-output-stream 247 (port _coding-system) 248 (with-current-buffer (sly-channel-get self 'buffer) 249 ;; HACK: no coding system 250 (set (make-local-variable 'sly-mrepl--dedicated-stream) 251 (sly-mrepl--open-dedicated-stream self port nil)))) 252 253 (sly-define-channel-method listener :clear-repl-history () 254 (with-current-buffer (sly-channel-get self 'buffer) 255 (let ((inhibit-read-only t)) 256 (erase-buffer) 257 (sly-mrepl--insert-note "Cleared REPL history")))) 258 259 (sly-define-channel-method listener :server-side-repl-close () 260 (with-current-buffer (sly-channel-get self 'buffer) 261 (sly-mrepl--teardown "Server side close" 'dont-signal-server))) 262 263 264 ;;; Button type 265 ;;; 266 (define-button-type 'sly-mrepl-part :supertype 'sly-part 267 'sly-button-inspect 268 #'(lambda (entry-idx value-idx) 269 (sly-eval-for-inspector `(slynk-mrepl:inspect-entry 270 ,sly-mrepl--remote-channel 271 ,entry-idx 272 ,value-idx) 273 :inspector-name (sly-maybe-read-inspector-name))) 274 'sly-button-describe 275 #'(lambda (entry-idx value-idx) 276 (sly-eval-describe `(slynk-mrepl:describe-entry ,sly-mrepl--remote-channel 277 ,entry-idx 278 ,value-idx))) 279 'sly-button-pretty-print 280 #'(lambda (entry-idx value-idx) 281 (sly-eval-describe `(slynk-mrepl:pprint-entry ,sly-mrepl--remote-channel 282 ,entry-idx 283 ,value-idx))) 284 'sly-mrepl-copy-part-to-repl 'sly-mrepl--copy-part-to-repl) 285 286 287 ;;; Internal functions 288 ;;; 289 (defun sly-mrepl--buffer-name (connection &optional handle) 290 (sly-buffer-name :mrepl :connection connection 291 :suffix handle)) 292 293 (defun sly-mrepl--teardown-repls (process) 294 (cl-loop for buffer in (buffer-list) 295 when (buffer-live-p buffer) 296 do (with-current-buffer buffer 297 (when (and (eq major-mode 'sly-mrepl-mode) 298 (eq sly-buffer-connection process)) 299 (sly-mrepl--teardown (process-get process 300 'sly-net-close-reason)))))) 301 302 (defun sly-mrepl--process () (get-buffer-process (current-buffer))) ;stupid 303 304 (defun sly-mrepl--mark () 305 "Returns a marker to the end of the last prompt." 306 (let ((proc (sly-mrepl--process))) 307 (unless proc (sly-user-error "Not in a connected REPL")) 308 (process-mark proc))) 309 310 (defun sly-mrepl--safe-mark () 311 "Like `sly-mrepl--mark', but safe if there's no process." 312 (if (sly-mrepl--process) (sly-mrepl--mark) (point-max))) 313 314 (defmacro sly-mrepl--commiting-text (props &rest body) 315 (declare (debug (sexp &rest form)) 316 (indent 1)) 317 (let ((start-sym (cl-gensym))) 318 `(let ((,start-sym (marker-position (sly-mrepl--mark))) 319 (inhibit-read-only t)) 320 ,@body 321 (add-text-properties ,start-sym (sly-mrepl--mark) 322 (append '(read-only t front-sticky (read-only)) 323 ,props))))) 324 325 (defun sly-mrepl--forward-sexp (n) 326 "Just like `forward-sexp' unless point it at prompt start. 327 In that case, moving a sexp backward does nothing." 328 (if (or (cl-plusp n) 329 (/= (point) (sly-mrepl--safe-mark))) 330 (let ((forward-sexp-function nil)) 331 (forward-sexp n)))) 332 333 (defun sly-mrepl--syntax-propertize (beg end) 334 "Make everything up to current prompt comment syntax." 335 (remove-text-properties beg end '(syntax-table nil)) 336 (let ((end (min end (sly-mrepl--safe-mark))) 337 (beg beg)) 338 (when (> end beg) 339 (unless (nth 8 (syntax-ppss beg)) 340 (add-text-properties beg (1+ beg) 341 `(syntax-table ,(string-to-syntax "!")))) 342 (add-text-properties (1- end) end 343 `(syntax-table ,(string-to-syntax "!")))))) 344 345 (defun sly-mrepl--call-with-repl (repl-buffer fn) 346 (with-current-buffer repl-buffer 347 (cl-loop 348 while (not (buffer-local-value 'sly-mrepl--remote-channel 349 (current-buffer))) 350 do 351 (sly-warning "Waiting for a REPL to be setup for %s" 352 (sly-connection-name (sly-current-connection))) 353 (sit-for 0.5)) 354 (funcall fn))) 355 356 (defmacro sly-mrepl--with-repl (repl-buffer &rest body) 357 (declare (indent 1) (debug (sexp &rest form))) 358 `(sly-mrepl--call-with-repl ,repl-buffer #'(lambda () ,@body))) 359 360 (defun sly-mrepl--insert (string &optional face) 361 (sly-mrepl--commiting-text (when face 362 `(face ,face font-lock-face ,face)) 363 (comint-output-filter (sly-mrepl--process) 364 (propertize string 'sly-mrepl-break-output t)))) 365 366 (defun sly-mrepl--break-output-p (pos) 367 (and (not (eq ?\n (char-after pos))) 368 (get-char-property pos 'sly-mrepl-break-output))) 369 370 (defun sly-mrepl--insert-output (string &optional face nofilters) 371 (cond ((and (not sly-mrepl--read-mark) string) 372 (let ((inhibit-read-only t) 373 (start (marker-position sly-mrepl--output-mark)) 374 (face (or face 375 'sly-mrepl-output-face))) 376 377 (save-excursion 378 (goto-char sly-mrepl--output-mark) 379 (cond ((and (not (bobp)) 380 (sly-mrepl--break-output-p (1- start)) 381 (not (zerop (current-column)))) 382 (insert-before-markers "\n"))) 383 (setq string 384 (propertize (concat sly-mrepl--pending-output string) 385 'face face 386 'font-lock-face face)) 387 (setq sly-mrepl--pending-output nil) 388 (unless nofilters 389 (run-hook-wrapped 390 'sly-mrepl-output-filter-functions 391 (lambda (fn) 392 (setq string (funcall fn string)) 393 nil))) 394 (insert-before-markers string) 395 (cond ((and (not (zerop (current-column))) 396 (sly-mrepl--break-output-p (point))) 397 (save-excursion (insert "\n")))) 398 (add-text-properties start sly-mrepl--output-mark 399 `(read-only t front-sticky (read-only) 400 field sly-mrepl--output))))) 401 (t 402 (setq sly-mrepl--pending-output 403 (concat sly-mrepl--pending-output string)) 404 (sly-message "Some output saved for later insertion")))) 405 406 (defun sly-mrepl--insert-note (string &optional face) 407 (let* ((face (or face 'sly-mrepl-note-face)) 408 (string (replace-regexp-in-string "^" "; " string))) 409 (cond ((sly-mrepl--process) 410 ;; notes are inserted "synchronously" with the process mark process 411 (sly-mrepl--ensure-newline) 412 (sly-mrepl--insert string face)) 413 (t 414 ;; If no process yet, fall back to the simpler strategy. 415 (sly-mrepl--insert-output string face))))) 416 417 (defun sly-mrepl--send-input-sexp () 418 (goto-char (point-max)) 419 (save-excursion 420 (skip-chars-backward "\n\t\s") 421 (delete-region (max (point) 422 (sly-mrepl--mark)) 423 (point-max))) 424 (buffer-disable-undo) 425 (overlay-put sly-mrepl--last-prompt-overlay 'face 'highlight) 426 (set (make-local-variable 'sly-mrepl--dirty-history) t) 427 (sly-mrepl--commiting-text 428 `(field sly-mrepl-input 429 keymap ,(let ((map (make-sparse-keymap))) 430 (define-key map (kbd "RET") 'sly-mrepl-insert-input) 431 (define-key map [return] 'sly-mrepl-insert-input) 432 (define-key map [mouse-2] 'sly-mrepl-insert-input) 433 map)) 434 (comint-send-input)) 435 (sly-mrepl--ensure-prompt-face)) 436 437 (defun sly-mrepl--ensure-newline () 438 (unless (save-excursion 439 (goto-char (sly-mrepl--mark)) 440 (zerop (current-column))) 441 (sly-mrepl--insert "\n"))) 442 443 (defun sly-mrepl--accept-process-output () 444 (when (and sly-mrepl--dedicated-stream 445 (process-live-p sly-mrepl--dedicated-stream)) 446 ;; This non-blocking call should be enough to allow asynch calls 447 ;; to `sly-mrepl--insert-output' to still see the correct value 448 ;; for `sly-mrepl--output-mark' just before we call 449 ;; `sly-mrepl--catch-up'. 450 (while (accept-process-output sly-mrepl--dedicated-stream 451 0 452 (and (eq (window-system) 'w32) 1))))) 453 454 (defun sly-mrepl--ensure-prompt-face () 455 "Override `comint.el''s use of `comint-highlight-prompt'." 456 (let ((inhibit-read-only t)) 457 (add-text-properties (overlay-start sly-mrepl--last-prompt-overlay) 458 (overlay-end sly-mrepl--last-prompt-overlay) 459 '(font-lock-face sly-mrepl-prompt-face)))) 460 461 (defun sly-mrepl--insert-prompt (package prompt error-level &optional condition) 462 (sly-mrepl--accept-process-output) 463 (overlay-put sly-mrepl--last-prompt-overlay 'face 'bold) 464 (when condition 465 (sly-mrepl--insert-note (format "Debugger entered on %s" condition))) 466 (sly-mrepl--ensure-newline) 467 (sly-mrepl--catch-up) 468 (let ((beg (marker-position (sly-mrepl--mark)))) 469 (sly-mrepl--insert 470 (propertize 471 (concat 472 (when (cl-plusp error-level) 473 (concat (sly-make-action-button 474 (format "[%d]" error-level) 475 #'sly-db-pop-to-debugger-maybe) 476 " ")) 477 (propertize 478 (concat prompt "> ") 479 'face 'sly-mrepl-prompt-face 480 'font-lock-face 'sly-mrepl-prompt-face)) 481 'sly-mrepl--prompt (downcase package))) 482 (move-overlay sly-mrepl--last-prompt-overlay beg (sly-mrepl--mark))) 483 (sly-mrepl--ensure-prompt-face) 484 (buffer-disable-undo) 485 (buffer-enable-undo)) 486 487 (defun sly-mrepl--copy-part-to-repl (entry-idx value-idx) 488 (sly-mrepl--copy-objects-to-repl 489 `(,entry-idx ,value-idx) 490 :before (format "Returning value %s of history entry %s" 491 value-idx entry-idx))) 492 493 (cl-defun sly-mrepl--eval-for-repl 494 (slyfun-and-args 495 &key insert-p before-prompt after-prompt (pop-to-buffer t)) 496 "Evaluate SLYFUN-AND-ARGS in Slynk, then call callbacks. 497 498 SLYFUN-AND-ARGS is (SLYFUN . ARGS) and is called in 499 Slynk. SLYFUN's multiple return values are captured in a list and 500 passed to the optional unary callbacks BEFORE-PROMPT and 501 AFTER-PROMPT, called before or after prompt insertion, 502 respectively. 503 504 If INSERT-P is non-nil, SLYFUN's results are printable 505 representations of Slynk objects and should be inserted into the 506 REPL. POP-TO-BUFFER says whether to pop the REPL buffer." 507 (sly-eval-async `(slynk-mrepl:eval-for-mrepl 508 ,sly-mrepl--remote-channel 509 ',(car slyfun-and-args) 510 ,@(cdr slyfun-and-args)) 511 (lambda (prompt-args-and-results) 512 (cl-destructuring-bind (prompt-args results) 513 prompt-args-and-results 514 (goto-char (sly-mrepl--mark)) 515 (let ((saved-text (buffer-substring (point) (point-max)))) 516 (delete-region (point) (point-max)) 517 (sly-mrepl--catch-up) 518 (when before-prompt 519 (funcall before-prompt results)) 520 (when insert-p 521 (sly-mrepl--insert-results results)) 522 (apply #'sly-mrepl--insert-prompt prompt-args) 523 (when pop-to-buffer 524 (pop-to-buffer (current-buffer))) 525 (goto-char (sly-mrepl--mark)) 526 (insert saved-text) 527 (when after-prompt 528 (funcall after-prompt results))))))) 529 530 (cl-defun sly-mrepl--copy-objects-to-repl 531 (method-args &key before after (pop-to-buffer t)) 532 "Recall objects in the REPL history as a new entry. 533 METHOD-ARGS are SLYNK-MREPL:COPY-TO-REPL's optional args. If nil 534 , consider the globally saved objects that 535 SLYNK-MREPL:GLOBALLY-SAVE-OBJECT stored. Otherwise, it is a 536 list (ENTRY-IDX VALUE-IDX). BEFORE and AFTER as in 537 `sly-mrepl--save-and-copy-for-repl' POP-TO-BUFFER as in 538 `sly-mrepl--eval-for-repl'." 539 (sly-mrepl--eval-for-repl 540 `(slynk-mrepl:copy-to-repl 541 ,@method-args) 542 :before-prompt (if (stringp before) 543 (lambda (objects) 544 (sly-mrepl--insert-note before) 545 (sly-mrepl--insert-results objects)) 546 before) 547 :after-prompt after 548 :pop-to-buffer pop-to-buffer)) 549 550 (defun sly-mrepl--make-result-button (result idx) 551 (sly--make-text-button (car result) nil 552 :type 'sly-mrepl-part 553 'part-args (list (cadr result) idx) 554 'part-label (format "REPL Result") 555 'sly-mrepl--result result 556 'sly-button-search-id (sly-button-next-search-id))) 557 558 (defun sly-mrepl--insert-results (results) 559 (let* ((comint-preoutput-filter-functions nil)) 560 (if (null results) 561 (sly-mrepl--insert-note "No values") 562 (cl-loop for result in results 563 for idx from 0 564 do 565 (sly-mrepl--ensure-newline) 566 (sly-mrepl--insert 567 (sly-mrepl--make-result-button result idx)))))) 568 569 (defun sly-mrepl--catch-up () 570 "Synchronize the output mark with the REPL process mark." 571 (set-marker sly-mrepl--output-mark (sly-mrepl--mark))) 572 573 (defun sly-mrepl--input-sender (_proc string) 574 (sly-mrepl--send-string (substring-no-properties string))) 575 576 (defun sly-mrepl--send-string (string &optional _command-string) 577 (sly-mrepl--send `(:process ,string))) 578 579 (defun sly-mrepl--send (msg) 580 "Send MSG to the remote channel." 581 (sly-send-to-remote-channel sly-mrepl--remote-channel msg)) 582 583 (defun sly-mrepl--find-buffer (&optional connection thread) 584 "Find the shortest-named (default) `sly-mrepl' buffer for CONNECTION." 585 ;; CONNECTION defaults to the `sly-default-connection' passing 586 ;; through `sly-connection'. Seems to work OK... 587 ;; 588 (let* ((connection (or connection 589 (let ((sly-buffer-connection nil) 590 (sly-dispatching-connection nil)) 591 (sly-connection)))) 592 (repls (cl-remove-if-not 593 (lambda (x) 594 (with-current-buffer x 595 (and (eq major-mode 'sly-mrepl-mode) 596 (eq sly-buffer-connection connection) 597 (or (not thread) 598 (eq thread sly-current-thread))))) 599 (buffer-list))) 600 (sorted (cl-sort repls #'< :key (sly-compose #'length #'buffer-name)))) 601 (car sorted))) 602 603 (defun sly-mrepl--find-create (connection) 604 (or (sly-mrepl--find-buffer connection) 605 (sly-mrepl-new connection))) 606 607 (defun sly-mrepl--busy-p () 608 (>= sly-mrepl--output-mark (sly-mrepl--mark))) 609 610 (defcustom sly-mrepl-history-file-name (expand-file-name "~/.sly-mrepl-history") 611 "File used to store SLY REPL's input history across sessions." 612 :type 'file 613 :group 'sly) 614 615 (defun sly-mrepl--read-input-ring () 616 (let ((comint-input-ring-separator sly-mrepl--history-separator) 617 (comint-input-ring-file-name sly-mrepl-history-file-name)) 618 (comint-read-input-ring))) 619 620 (defcustom sly-mrepl-prevent-duplicate-history 'move 621 "If non-nil, prevent duplicate entries in input history. 622 623 Otherwise (if nil), input entry are always added to the end of 624 the history, even if they already occur in the history. 625 626 If the non-nil value is `move', the previously occuring entry is 627 discarded, i.e. moved to a more recent spot. Any other non-nil 628 value laves the previous entry untouched and it is the more 629 recent entry that is discarded." 630 :type 'symbol 631 :group 'sly) 632 633 (defun sly-mrepl--merge-and-save-history () 634 (let* 635 ;; To merge the file's history with the current buffer's 636 ;; history, sntart by deep-copying `comint-input-ring' to a 637 ;; separate variable. 638 ;; 639 ((current-ring (copy-tree comint-input-ring 'vectors-too)) 640 (index (ring-length current-ring)) 641 (comint-input-ring-separator sly-mrepl--history-separator) 642 (comint-input-ring-file-name sly-mrepl-history-file-name)) 643 ;; this sets `comint-input-ring' from the file 644 ;; 645 (sly-mrepl--read-input-ring) 646 ;; loop `current-ring', which potentially contains new entries and 647 ;; re-add entries to `comint-input-ring', which is now synched 648 ;; with the file and will be written to disk. Respect 649 ;; `sly-mrepl-prevent-duplicate-history'. 650 ;; 651 (cl-loop for i from (1- index) downto 0 652 for item = (ring-ref current-ring i) 653 for existing-index = (ring-member comint-input-ring item) 654 do (cond ((and existing-index 655 (eq sly-mrepl-prevent-duplicate-history 'move)) 656 (ring-remove comint-input-ring existing-index) 657 (ring-insert comint-input-ring item)) 658 ((and existing-index 659 (not sly-mrepl-prevent-duplicate-history)) 660 (ring-insert comint-input-ring item)) 661 (t 662 (ring-insert comint-input-ring item))) 663 unless (ring-member comint-input-ring item) 664 do (ring-insert comint-input-ring item)) 665 ;; Now save `comint-input-ring' 666 (let ((coding-system-for-write 'utf-8-unix)) 667 (comint-write-input-ring)) 668 (set (make-local-variable 'sly-mrepl--dirty-history) nil))) 669 670 (defun sly-mrepl--save-all-histories () 671 (cl-loop for buffer in (buffer-list) 672 do 673 (with-current-buffer buffer 674 (when (and (eq major-mode 'sly-mrepl-mode) 675 sly-mrepl--dirty-history) 676 (sly-mrepl--merge-and-save-history))))) 677 678 (defun sly-mrepl--teardown (&optional reason dont-signal-server) 679 (remove-hook 'kill-buffer-hook 'sly-mrepl--teardown t) 680 (let ((inhibit-read-only t)) 681 (goto-char (point-max)) 682 (let ((start (point))) 683 (unless (zerop (current-column)) (insert "\n")) 684 (insert (format "; %s" (or reason "REPL teardown"))) 685 (unless (zerop (current-column)) (insert "\n")) 686 (insert "; --------------------------------------------------------\n") 687 (add-text-properties start (point) '(read-only t)))) 688 (sly-mrepl--merge-and-save-history) 689 (when sly-mrepl--dedicated-stream 690 (process-put sly-mrepl--dedicated-stream 'sly-mrepl--channel nil) 691 (kill-buffer (process-buffer sly-mrepl--dedicated-stream))) 692 (sly-close-channel sly-mrepl--local-channel) 693 ;; signal lisp that we're closingq 694 (unless dont-signal-server 695 (ignore-errors 696 ;; uses `sly-connection', which falls back to 697 ;; `sly-buffer-connection'. If that is closed it's probably 698 ;; because lisp died from (SLYNK:QUIT-LISP) already, and so 699 (sly-mrepl--send `(:teardown)))) 700 (set (make-local-variable 'sly-mrepl--remote-channel) nil) 701 (when (sly-mrepl--process) 702 (delete-process (sly-mrepl--process)))) 703 704 (defun sly-mrepl--dedicated-stream-output-filter (process string) 705 (let* ((channel (process-get process 'sly-mrepl--channel)) 706 (buffer (and channel 707 (sly-channel-get channel 'buffer)))) 708 (if (buffer-live-p buffer) 709 (with-current-buffer buffer 710 (when (and (cl-plusp (length string)) 711 (eq (process-status sly-buffer-connection) 'open)) 712 (sly-mrepl--insert-output string))) 713 (sly-warning "No channel in process %s, probably torn down" process)))) 714 715 (defun sly-mrepl--open-dedicated-stream (channel port coding-system) 716 (let* ((name (format "sly-dds-%s-%s" 717 (process-get sly-buffer-connection 718 'sly--net-connect-counter) 719 (sly-channel.id channel))) 720 (stream (open-network-stream 721 name 722 (generate-new-buffer 723 (format " *%s*" name)) 724 (car (process-contact sly-buffer-connection)) 725 port)) 726 (emacs-coding-system (car (cl-find coding-system 727 sly-net-valid-coding-systems 728 :key #'cl-third)))) 729 (set-process-query-on-exit-flag stream nil) 730 (set-process-plist stream `(sly-mrepl--channel ,channel)) 731 (set-process-filter stream 'sly-mrepl--dedicated-stream-output-filter) 732 (set-process-coding-system stream emacs-coding-system emacs-coding-system) 733 (sly--when-let (secret (sly-secret)) 734 (sly-net-send secret stream)) 735 (run-hook-with-args 'sly-mrepl--dedicated-stream-hooks stream) 736 stream)) 737 738 (cl-defun sly-mrepl--save-and-copy-for-repl 739 (slyfun-and-args &key repl before after) 740 "Evaluate SLYFUN-AND-ARGS in Slynk and prepare to copy to REPL. 741 BEFORE is a string inserted as a note, or a nullary function 742 which is run just before the object is copied to the 743 REPL. Optional BEFORE and AFTER are unary functions called with a 744 list of the saved values' presentations strings and run before 745 and after the the the prompt are inserted, respectively. BEFORE 746 can also be a string in which case it is inserted via 747 `sly-insert-note' followed by the saved values' presentations. 748 REPL is the REPL buffer to return the objects to." 749 (sly-eval-async 750 `(slynk-mrepl:globally-save-object ',(car slyfun-and-args) 751 ,@(cdr slyfun-and-args)) 752 #'(lambda (_ignored) 753 (sly-mrepl--copy-globally-saved-to-repl :before before 754 :after after 755 :repl repl)))) 756 757 (cl-defun sly-mrepl--copy-globally-saved-to-repl 758 (&key before after repl (pop-to-buffer t)) 759 "Copy last globally saved values to REPL, or active REPL. 760 BEFORE and AFTER as described in 761 `sly-mrepl--save-and-copy-for-repl'." 762 (sly-mrepl--with-repl (or repl 763 (sly-mrepl--find-create (sly-connection))) 764 (sly-mrepl--copy-objects-to-repl nil 765 :before before 766 :after after 767 :pop-to-buffer pop-to-buffer))) 768 769 (defun sly-mrepl--insert-call (spec results) 770 (delete-region (sly-mrepl--mark) (point-max)) 771 (insert (format 772 "%s" 773 `(,spec 774 ,@(cl-loop for (_object j constant) in results 775 for i from 0 776 collect 777 (or constant 778 (make-symbol (format "#v%d:%d" j i)))))))) 779 780 (defun sly-mrepl--assert-mrepl () 781 (unless (eq major-mode 'sly-mrepl-mode) 782 (sly-error "Not in a mREPL buffer"))) 783 784 785 ;;; ELI-like history (and a bugfix) 786 ;;; 787 ;;; 788 (defcustom sly-mrepl-eli-like-history-navigation nil 789 "If non-NIL navigate history like ELI. 790 When this option is active, previous history entries navigated to 791 by M-p and M-n keep the current input and use it to surround the 792 history entry navigated to." 793 :type 'boolean 794 :group 'sly) 795 796 (defvar sly-mrepl--eli-input nil) 797 798 (defun sly-mrepl--set-eli-input () 799 (setq sly-mrepl--eli-input 800 (and sly-mrepl-eli-like-history-navigation 801 (let* ((offset (- (point) (sly-mrepl--mark))) 802 (existing (and (> offset 0) 803 (buffer-substring (sly-mrepl--mark) 804 (point-max))))) 805 (when existing 806 (cons (substring existing 0 offset) 807 (substring existing offset))))))) 808 809 (defun sly-mrepl--keep-eli-input-maybe () 810 (when sly-mrepl--eli-input 811 (save-excursion 812 (goto-char (sly-mrepl--mark)) 813 (insert (car sly-mrepl--eli-input)) 814 (goto-char (point-max)) 815 (insert (cdr sly-mrepl--eli-input))))) 816 817 (defvar sly-mrepl--eli-input-overlay nil) 818 819 (defun sly-mrepl--surround-with-eli-input-overlay () 820 (if sly-mrepl--eli-input-overlay 821 (move-overlay sly-mrepl--eli-input-overlay 822 (sly-mrepl--mark) (point-max)) 823 (setq sly-mrepl--eli-input-overlay 824 (make-overlay (sly-mrepl--mark) (point-max)))) 825 (overlay-put sly-mrepl--eli-input-overlay 826 'before-string (car sly-mrepl--eli-input)) 827 (overlay-put sly-mrepl--eli-input-overlay 828 'after-string (cdr sly-mrepl--eli-input))) 829 830 (defun sly-mrepl--setup-comint-isearch () 831 ;; Defeat Emacs bug 19572 in Emacs whereby comint refuses to 832 ;; i-search multi-line history entries. The doc of 833 ;; `isearch-search-fun-function' should explain the need for this 834 ;; lambda madness. 835 ;; 836 (unless (eq isearch-search-fun-function 837 'isearch-search-fun-default) 838 (set (make-local-variable 'isearch-search-fun-function) 839 #'(lambda () 840 #'(lambda (&rest args) 841 (cl-letf 842 (((symbol-function 843 'comint-line-beginning-position) 844 #'field-beginning)) 845 (apply (comint-history-isearch-search) 846 args)))))) 847 (sly-mrepl--set-eli-input) 848 (when sly-mrepl-eli-like-history-navigation 849 (set (make-local-variable 'isearch-push-state-function) 850 #'sly-mrepl--isearch-push-state))) 851 852 (defun sly-mrepl--isearch-push-state (&rest args) 853 (apply #'comint-history-isearch-push-state args) 854 (unless (memq this-command 855 '(isearch-backward isearch-forward)) 856 (sly-mrepl--surround-with-eli-input-overlay))) 857 858 (defun sly-mrepl--teardown-comint-isearch () 859 (set (make-local-variable 'isearch-search-fun-function) 860 'isearch-search-fun-default) 861 (when (overlayp sly-mrepl--eli-input-overlay) 862 (delete-overlay sly-mrepl--eli-input-overlay) 863 (setq sly-mrepl--eli-input-overlay nil)) 864 (sly-mrepl--keep-eli-input-maybe)) 865 866 867 ;;; Interactive commands 868 ;;; 869 (defun sly-mrepl-indent-and-complete-symbol (arg) 870 "Indent the current line, perform symbol completion or show arglist. 871 Completion performed by `completion-at-point' or 872 `company-complete'. If there's no symbol at the point, show the 873 arglist for the most recently enclosed macro or function." 874 (interactive "P") 875 (let ((pos (point)) 876 (fn (if (bound-and-true-p company-mode) 877 'company-complete 878 'completion-at-point))) 879 (indent-for-tab-command arg) 880 (when (= pos (point)) 881 (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) 882 (funcall fn)) 883 ((memq (char-before) '(?\t ?\ )) 884 (sly-show-arglist)))))) 885 886 (defun sly-mrepl-return (&optional end-of-input) 887 "If the input is a whole expression, evaluate it and return the result." 888 (interactive "P") 889 (cl-assert (sly-connection)) 890 (cl-assert (process-live-p (sly-mrepl--process)) nil 891 "No local live process, cannot use this REPL") 892 (accept-process-output) 893 (cond ((and 894 (not sly-mrepl--read-mark) 895 (sly-mrepl--busy-p)) 896 (sly-message "REPL is busy")) 897 ((and (not sly-mrepl--read-mark) 898 (or (sly-input-complete-p (sly-mrepl--mark) (point-max)) 899 end-of-input)) 900 (sly-mrepl--send-input-sexp) 901 (sly-mrepl--catch-up)) 902 (sly-mrepl--read-mark 903 (unless end-of-input 904 (goto-char (point-max)) 905 (newline)) 906 (let ((comint-input-filter (lambda (_s) nil))) 907 (comint-send-input 'no-newline)) 908 (sly-mrepl--catch-up)) 909 (t 910 (newline-and-indent) 911 (sly-message "Input not complete")))) 912 913 (defun sly-mrepl-previous-input-or-button (n) 914 (interactive "p") 915 (if (>= (point) (sly-mrepl--mark)) 916 (progn 917 (unless (memq last-command 918 '(sly-mrepl-previous-input-or-button 919 sly-mrepl-next-input-or-button)) 920 (sly-mrepl--set-eli-input)) 921 (comint-previous-input n) 922 (sly-mrepl--keep-eli-input-maybe)) 923 (sly-button-backward n))) 924 925 (defun sly-mrepl-next-input-or-button (n) 926 (interactive "p") 927 (sly-mrepl-previous-input-or-button (- n))) 928 929 (put 'sly-mrepl-next-input-or-button 'sly-button-navigation-command t) 930 (put 'sly-mrepl-previous-input-or-button 'sly-button-navigation-command t) 931 932 (defun sly-mrepl (&optional display-action) 933 "Find or create the first useful REPL for the default connection. 934 If supplied, DISPLAY-ACTION is called on the 935 buffer. Interactively, DISPLAY-ACTION defaults to using 936 `switch-to-buffer' unless the intended buffer is already visible 937 in some window, in which case that window is selected." 938 (interactive (list (lambda (buf) 939 (let ((w (get-buffer-window buf))) 940 (if w (select-window w) (switch-to-buffer buf)))))) 941 (let* ((buffer 942 (sly-mrepl--find-create (sly-current-connection)))) 943 (when display-action 944 (funcall display-action buffer)) 945 buffer)) 946 947 (defun sly-mrepl-on-connection () 948 (let* ((inferior-buffer 949 (and (sly-process) (process-buffer (sly-process)))) 950 (inferior-window 951 (and inferior-buffer (get-buffer-window inferior-buffer t)))) 952 (let ((sly-mrepl-pop-sylvester 953 (or (eq sly-mrepl-pop-sylvester 'on-connection) 954 sly-mrepl-pop-sylvester))) 955 (sly-mrepl 'pop-to-buffer)) 956 (when inferior-window 957 (bury-buffer inferior-buffer) 958 (delete-window inferior-window)) 959 (goto-char (point-max)))) 960 961 (defun sly-mrepl-new (connection &optional handle) 962 "Create and setup a new REPL buffer for CONNECTION. 963 CONNECTION defaults to the current SLY connection. If such a 964 buffer already exists, or a prefix arg is given, prompt for a 965 handle to distinguish the new buffer from the existing." 966 (interactive 967 ;; FIXME: Notice a subtle bug/feature than when calling 968 ;; interactively in a buffer which has a connection, but not the 969 ;; default connection, the new REPL will be for that connection. 970 (let ((connection (sly-connection))) 971 (list connection 972 (if (or (get-buffer (sly-mrepl--buffer-name connection)) 973 current-prefix-arg) 974 (sly-read-from-minibuffer 975 "Nickname for this new REPL? "))))) 976 (let* ((name (sly-mrepl--buffer-name connection handle)) 977 (existing (get-buffer name))) 978 (when (and handle existing) 979 (sly-user-error "A REPL with that handle already exists")) 980 ;; Take this oportunity to save any other REPL histories so that 981 ;; the new REPL will see them. 982 (sly-mrepl--save-all-histories) 983 (let* ((local (sly-make-channel sly-listener-channel-methods)) 984 (buffer (pop-to-buffer name)) 985 (default-directory (if (file-readable-p default-directory) 986 default-directory 987 (expand-file-name "~/")))) 988 (with-current-buffer buffer 989 (sly-mrepl-mode) 990 (when (and (not existing) 991 (eq sly-mrepl-pop-sylvester t)) 992 (sly-mrepl--insert-note 993 (concat "\n" (sly-mrepl-random-sylvester) "\n\n") 994 'sly-mrepl-output-face)) 995 (setq sly-buffer-connection connection) 996 (start-process (format "sly-pty-%s-%s" 997 (process-get connection 998 'sly--net-connect-counter) 999 (sly-channel.id local)) 1000 (current-buffer) 1001 nil) 1002 (set-process-query-on-exit-flag (sly-mrepl--process) nil) 1003 (setq header-line-format 1004 (format "Waiting for REPL creation ack for channel %d..." 1005 (sly-channel.id local))) 1006 (sly-channel-put local 'buffer (current-buffer)) 1007 (add-hook 'kill-buffer-hook 'sly-mrepl--teardown nil 'local) 1008 (set (make-local-variable 'sly-mrepl--local-channel) local)) 1009 (sly-eval-async 1010 `(slynk-mrepl:create-mrepl ,(sly-channel.id local)) 1011 (lambda (result) 1012 (cl-destructuring-bind (remote thread-id) result 1013 (with-current-buffer buffer 1014 (sly-mrepl--read-input-ring) 1015 (setq header-line-format nil) 1016 (setq sly-current-thread thread-id) 1017 (set (make-local-variable 'sly-mrepl--remote-channel) remote) 1018 (unwind-protect 1019 (run-hooks 'sly-mrepl-hook 'sly-mrepl-runonce-hook) 1020 (set-default 'sly-mrepl-runonce-hook nil)))))) 1021 buffer))) 1022 1023 (defun sly-mrepl-insert-input (pos) 1024 (interactive (list (if (mouse-event-p last-input-event) 1025 (posn-point (event-end last-input-event)) 1026 (point)))) 1027 (sly-mrepl--assert-mrepl) 1028 (let* ((pos (if (eq (field-at-pos pos) 'sly-mrepl-input) 1029 pos 1030 (1+ pos))) 1031 (new-input (and 1032 (eq (field-at-pos (1+ pos)) 'sly-mrepl-input) 1033 (field-string-no-properties pos))) 1034 (offset (and new-input 1035 (- (point) (field-beginning pos))))) 1036 (cond (new-input 1037 (goto-char (sly-mrepl--mark)) 1038 (delete-region (point) (point-max)) 1039 (insert (sly-trim-whitespace new-input)) 1040 (goto-char (+ (sly-mrepl--mark) offset))) 1041 (t 1042 (sly-user-error "No input at point"))))) 1043 1044 (defun sly-mrepl-guess-package (&optional point interactive) 1045 (interactive (list (point) t)) 1046 (let* ((point (or point (point))) 1047 (probe 1048 (previous-single-property-change point 1049 'sly-mrepl--prompt)) 1050 (package (and probe 1051 (or (get-text-property probe 'sly-mrepl--prompt) 1052 (let ((probe2 1053 (previous-single-property-change 1054 probe 'sly-mrepl--prompt))) 1055 (and probe2 1056 (get-text-property probe2 1057 'sly-mrepl--prompt))))))) 1058 (when interactive 1059 (sly-message "Guessed package \"%s\"" package)) 1060 package)) 1061 1062 (define-obsolete-function-alias 1063 'sly-mrepl-sync-package-and-default-directory 'sly-mrepl-sync 1064 "1.0.0-alpha-3") 1065 1066 (defun sly-mrepl-sync (&optional package directory expression) 1067 "Go to the REPL, and set Slynk's PACKAGE and DIRECTORY. 1068 Also yank EXPRESSION into the prompt. Interactively gather 1069 PACKAGE and DIRECTORY these values from the current buffer, if 1070 available. In this scenario EXPRESSION is only set if a C-u 1071 prefix argument is given." 1072 (interactive (list (sly-current-package) 1073 (and buffer-file-name 1074 default-directory) 1075 (and current-prefix-arg 1076 (sly-last-expression)))) 1077 (sly-mrepl--with-repl (sly-mrepl--find-create (sly-connection)) 1078 (when directory 1079 (cd directory)) 1080 (sly-mrepl--eval-for-repl 1081 `(slynk-mrepl:sync-package-and-default-directory 1082 :package-name ,package 1083 :directory ,(and directory 1084 (sly-to-lisp-filename directory))) 1085 :insert-p nil 1086 :before-prompt 1087 #'(lambda (results) 1088 (cl-destructuring-bind (package-2 directory-2) results 1089 (sly-mrepl--insert-note 1090 (cond ((and package directory) 1091 (format "Synched package to %s and directory to %s" 1092 package-2 directory-2)) 1093 (directory 1094 (format "Synched directory to %s" directory-2)) 1095 (package 1096 (format "Synched package to %s" package-2)) 1097 (t 1098 (format "Remaining in package %s and directory %s" 1099 package-2 directory-2)))))) 1100 :after-prompt 1101 #'(lambda (_results) 1102 (when expression 1103 (goto-char (point-max)) 1104 (let ((saved (point))) 1105 (insert expression) 1106 (when (string-match "\n" expression) 1107 (indent-region saved (point-max))))))))) 1108 1109 (defun sly-mrepl-clear-repl () 1110 "Clear all this REPL's output history. 1111 Doesn't clear input history." 1112 (interactive) 1113 (sly-mrepl--assert-mrepl) 1114 (sly-mrepl--send `(:clear-repl-history))) 1115 1116 (defun sly-mrepl-clear-recent-output () 1117 "Clear this REPL's output between current and last prompt." 1118 (interactive) 1119 (sly-mrepl--assert-mrepl) 1120 (cl-loop for search-start = 1121 (set-marker (make-marker) 1122 (1+ (overlay-start sly-mrepl--last-prompt-overlay))) 1123 then pos 1124 for pos = (set-marker 1125 search-start 1126 (previous-single-property-change search-start 'field)) 1127 while (and (marker-position pos) 1128 ;; FIXME: fragile (1- pos), use narrowing 1129 (not (get-text-property (1- pos) 'sly-mrepl--prompt)) 1130 (> pos (point-min))) 1131 when (eq (field-at-pos pos) 'sly-mrepl--output) 1132 do (let ((inhibit-read-only t)) 1133 (delete-region (field-beginning pos) 1134 (+ 1135 (if (eq ?\n (char-before (field-end pos))) 0 1) 1136 (field-end pos))) 1137 (sly-mrepl--insert-output "; Cleared last output" 1138 'sly-mrepl-note-face)) 1139 and return nil) 1140 (sly-message "Cleared last output")) 1141 1142 (defun sly-mrepl-next-prompt () 1143 "Go to the beginning of the next REPL prompt." 1144 (interactive) 1145 (let ((pos (next-single-char-property-change (line-beginning-position 2) 1146 'sly-mrepl--prompt))) 1147 (goto-char pos)) 1148 (end-of-line)) 1149 1150 (defun sly-mrepl-previous-prompt () 1151 "Go to the beginning of the previous REPL prompt." 1152 (interactive) 1153 ;; This has two wrinkles around the first prompt: (1) when going to 1154 ;; the first prompt it leaves point at column 0 (1) when called from 1155 ;; frist prompt goes to beginning of buffer. The correct fix is to 1156 ;; patch comint.el's comint-next-prompt and comint-previous-prompt 1157 ;; anyway... 1158 (let* ((inhibit-field-text-motion t) 1159 (pos (previous-single-char-property-change (1- (line-beginning-position)) 1160 'sly-mrepl--prompt))) 1161 (goto-char pos) 1162 (goto-char (line-beginning-position))) 1163 (end-of-line)) 1164 1165 1166 ;;; "External" non-interactive functions for plugging into 1167 ;;; other parts of SLY 1168 ;;; 1169 (defun sly-inspector-copy-part-to-repl (number) 1170 "Evaluate the inspector slot at point via the REPL (to set `*')." 1171 (sly-mrepl--save-and-copy-for-repl 1172 ;; FIXME: Using SLYNK:EVAL-FOR-INSPECTOR here repeats logic from 1173 ;; sly.el's `sly-eval-for-inspector', but we can't use that here 1174 ;; because we're already using `sly-mrepl--save-and-copy-for-repl'. 1175 ;; Investigate if these functions could maybe be macros instead. 1176 `(slynk:eval-for-inspector 1177 ,sly--this-inspector-name 1178 nil 1179 'slynk:inspector-nth-part-or-lose 1180 ,number) 1181 :before (format "Returning inspector slot %s" number))) 1182 1183 (defun sly-db-copy-part-to-repl (frame-id var-id) 1184 "Evaluate the frame var at point via the REPL (to set `*')." 1185 (sly-mrepl--save-and-copy-for-repl 1186 `(slynk-backend:frame-var-value ,frame-id ,var-id) 1187 :repl (sly-mrepl--find-buffer (sly-current-connection) sly-current-thread) 1188 :before (format "Returning var %s of frame %s" var-id frame-id))) 1189 1190 (defun sly-apropos-copy-symbol-to-repl (name _type) 1191 (sly-mrepl--save-and-copy-for-repl 1192 `(common-lisp:identity ',(car (read-from-string name))) 1193 :before (format "Returning symbol %s" name))) 1194 1195 (defun sly-trace-dialog-copy-part-to-repl (id part-id type) 1196 "Eval the Trace Dialog entry under point in the REPL (to set *)" 1197 (sly-mrepl--save-and-copy-for-repl 1198 `(slynk-trace-dialog:trace-part-or-lose ,id ,part-id ,type) 1199 :before (format "Returning part %s (%s) of trace entry %s" part-id type id))) 1200 1201 (defun sly-db-copy-call-to-repl (frame-id spec) 1202 (sly-mrepl--save-and-copy-for-repl 1203 `(slynk-backend:frame-arguments ,frame-id) 1204 :before (format "The actual arguments passed to frame %s" frame-id) 1205 :after #'(lambda (objects) 1206 (sly-mrepl--insert-call spec objects)))) 1207 1208 (defun sly-trace-dialog-copy-call-to-repl (trace-id spec) 1209 (sly-mrepl--save-and-copy-for-repl 1210 `(slynk-trace-dialog:trace-arguments-or-lose ,trace-id) 1211 :before (format "The actual arguments passed to trace %s" trace-id) 1212 :after #'(lambda (objects) 1213 (sly-mrepl--insert-call spec objects)))) 1214 1215 (defun sly-mrepl-inside-string-or-comment-p () 1216 (let ((mark (and (process-live-p (sly-mrepl--process)) 1217 (sly-mrepl--mark)))) 1218 (when (and mark (> (point) mark)) 1219 (let ((ppss (parse-partial-sexp mark (point)))) 1220 (or (nth 3 ppss) (nth 4 ppss)))))) 1221 1222 1223 ;;; The comma shortcut 1224 ;;; 1225 (defvar sly-mrepl-shortcut-history nil "History for sly-mrepl-shortcut.") 1226 1227 (defun sly-mrepl-reset-shortcut (key-sequence) 1228 "Set `sly-mrepl-shortcut' and reset REPL keymap accordingly." 1229 (interactive "kNew shortcut key sequence? ") 1230 (when (boundp 'sly-mrepl-shortcut) 1231 (define-key sly-mrepl-mode-map sly-mrepl-shortcut nil)) 1232 (set-default 'sly-mrepl-shortcut key-sequence) 1233 (define-key sly-mrepl-mode-map key-sequence 1234 '(menu-item "" sly-mrepl-shortcut 1235 :filter (lambda (cmd) 1236 (if (and (eq major-mode 'sly-mrepl-mode) 1237 (sly-mrepl--shortcut-location-p)) 1238 cmd))))) 1239 1240 (defcustom sly-mrepl-shortcut (kbd ",") 1241 "Keybinding string used for the REPL shortcut commands. 1242 When setting this variable outside of the Customize interface, 1243 `sly-mrepl-reset-shortcut' must be used." 1244 :group 'sly 1245 :type 'key-sequence 1246 :set (lambda (_sym value) 1247 (sly-mrepl-reset-shortcut value))) 1248 1249 (defun sly-mrepl--shortcut-location-p () 1250 (or (< (point) (sly-mrepl--mark)) 1251 (and (not (let ((state (syntax-ppss))) 1252 (or (nth 3 state) (nth 4 state)))) 1253 (or (not (equal sly-mrepl-shortcut ",")) 1254 (not (save-excursion 1255 (search-backward "`" (sly-mrepl--mark) 'noerror))))))) 1256 1257 (defvar sly-mrepl-shortcut-alist 1258 ;; keep this alist ordered by the key value, in order to make it easier to see 1259 ;; the identifying prefixes and keep them short 1260 '(("cd" . sly-mrepl-set-directory) 1261 ("clear repl" . sly-mrepl-clear-repl) 1262 ("disconnect" . sly-disconnect) 1263 ("disconnect all" . sly-disconnect-all) 1264 ("in-package" . sly-mrepl-set-package) 1265 ("restart lisp" . sly-restart-inferior-lisp) 1266 ("quit lisp" . sly-quit-lisp) 1267 ("sayoonara" . sly-quit-lisp) 1268 ("set directory" . sly-mrepl-set-directory) 1269 ("set package" . sly-mrepl-set-package))) 1270 1271 1272 (defun sly-mrepl-set-package () 1273 (interactive) 1274 (let ((package (sly-read-package-name "New package: "))) 1275 (sly-mrepl--eval-for-repl `(slynk-mrepl:guess-and-set-package ,package)))) 1276 1277 (defun sly-mrepl-set-directory () 1278 (interactive) 1279 (let ((directory (read-directory-name "New directory: " 1280 default-directory nil t))) 1281 (sly-mrepl--save-and-copy-for-repl 1282 `(slynk:set-default-directory ,directory) 1283 :before (format "Setting directory to %s" directory)) 1284 (cd directory))) 1285 1286 (defun sly-mrepl-shortcut () 1287 (interactive) 1288 (let* ((string (sly-completing-read "Command: " 1289 (mapcar #'car sly-mrepl-shortcut-alist) 1290 nil 'require-match nil 1291 'sly-mrepl-shortcut-history 1292 (car sly-mrepl-shortcut-history))) 1293 (command (and string 1294 (cdr (assoc string sly-mrepl-shortcut-alist))))) 1295 (call-interactively command))) 1296 1297 1298 ;;; Backreference highlighting 1299 ;;; 1300 (defvar sly-mrepl--backreference-overlays nil 1301 "List of overlays on top of REPL result buttons.") 1302 (make-variable-buffer-local 'sly-mrepl--backreference-overlays) 1303 1304 (defun sly-mrepl-highlight-results (&optional entry-idx value-idx) 1305 "Highlight REPL results for ENTRY-IDX and VALUE-IDX. 1306 If VALUE-IDX is nil or `all', highlight all results for entry 1307 ENTRY-IDX. If ENTRY-IDX is nil, highlight all results. Returns 1308 a list of result buttons thus highlighted" 1309 (interactive) 1310 (cl-loop 1311 for button in (sly-button-buttons-in (point-min) (point-max)) 1312 for e-idx = (car (button-get button 'part-args)) 1313 for v-idx = (cadr (button-get button 'part-args)) 1314 when (and (button-type-subtype-p (button-type button) 'sly-mrepl-part) 1315 (eq (button-get button 'sly-connection) (sly-current-connection)) 1316 (not (button-get button 'sly-mrepl--highlight-overlay)) 1317 (and (or (not entry-idx) 1318 (= e-idx entry-idx)) 1319 (or (not value-idx) 1320 (eq value-idx 'all) 1321 (= v-idx value-idx)))) 1322 collect button and 1323 do (let ((overlay (make-overlay (button-start button) (button-end button)))) 1324 (push overlay sly-mrepl--backreference-overlays) 1325 (overlay-put overlay 'before-string 1326 (concat 1327 (propertize 1328 (format "%s:%s" 1329 (car (button-get button 'part-args)) 1330 (cadr (button-get button 'part-args))) 1331 'face 'highlight) 1332 " "))))) 1333 1334 (defun sly-mrepl-unhighlight-results () 1335 "Unhighlight all repl results" 1336 (interactive) 1337 (mapc #'delete-overlay sly-mrepl--backreference-overlays) 1338 (setq sly-mrepl--backreference-overlays nil)) 1339 1340 (defvar sly-mrepl--backreference-overlay nil) 1341 (defvar sly-mrepl--backreference-prefix "#v") 1342 1343 (defun sly-mrepl--highlight-backreferences-maybe () 1344 "Intended to be placed in `post-command-hook'." 1345 (sly-mrepl-unhighlight-results) 1346 (when sly-mrepl--backreference-overlay 1347 (delete-overlay sly-mrepl--backreference-overlay)) 1348 (let* ((match (save-excursion 1349 (sly-beginning-of-symbol) 1350 (looking-at 1351 (format "%s\\([[:digit:]]+\\)?\\(:\\([[:digit:]]+\\)\\|:\\)?" 1352 sly-mrepl--backreference-prefix)))) 1353 (m0 (and match (match-string 0))) 1354 (m1 (and m0 (match-string 1))) 1355 (m2 (and m1 (match-string 2))) 1356 (m3 (and m2 (match-string 3))) 1357 (entry-idx (and m1 (string-to-number m1))) 1358 (value-idx (and match 1359 (or (and m3 (string-to-number m3)) 1360 (and (not m2) 1361 'all))))) 1362 (if (null match) 1363 (set (make-local-variable 'sly-autodoc-preamble) nil) 1364 (let ((buttons (sly-mrepl-highlight-results entry-idx value-idx)) 1365 (overlay 1366 (or sly-mrepl--backreference-overlay 1367 (set (make-local-variable 'sly-mrepl--backreference-overlay) 1368 (make-overlay 0 0)))) 1369 (message-log-max nil) 1370 (message-text)) 1371 (move-overlay sly-mrepl--backreference-overlay 1372 (match-beginning 0) (match-end 0)) 1373 (cond 1374 ((null buttons) 1375 (overlay-put overlay 'face 'font-lock-warning-face) 1376 (setq message-text (format "No history references for backreference `%s'" m0))) 1377 ((and buttons 1378 entry-idx 1379 value-idx) 1380 (overlay-put overlay 'face 'sly-action-face) 1381 (let* ((prefix (if (numberp value-idx) 1382 (format "Matched history value %s of entry %s: " 1383 value-idx 1384 entry-idx) 1385 (format "Matched history entry %s%s: " 1386 entry-idx 1387 (if (cl-rest buttons) 1388 (format " (%s values)" (length buttons)) 1389 "")))) 1390 (hint (propertize 1391 (truncate-string-to-width 1392 (replace-regexp-in-string "\n" " " 1393 (button-label 1394 (cl-first buttons))) 1395 (- (window-width (minibuffer-window)) 1396 (length prefix) 10) 1397 nil 1398 nil 1399 "...") 1400 'face 1401 'sly-action-face))) 1402 (setq message-text (format "%s" (format "%s%s" prefix hint))))) 1403 (buttons 1404 (setq message-text (format "Ambiguous backreference `%s', %s values possible" 1405 m0 (length buttons))) 1406 (overlay-put overlay 'face 'font-lock-warning-face)) 1407 (t 1408 (overlay-put overlay 'face 'font-lock-warning-face) 1409 (setq message-text (format "Invalid backreference `%s'" m0)))) 1410 (sly-message "%s" message-text) 1411 (set (make-local-variable 'sly-autodoc-preamble) message-text))))) 1412 1413 1414 ;;;; Menu 1415 ;;;; 1416 (easy-menu-define sly-mrepl--shortcut-menu nil 1417 "Menu for accessing the mREPL anywhere in sly." 1418 (let* ((C '(sly-connected-p))) 1419 `("mREPL" 1420 ["Go to default REPL" sly-mrepl ,C] 1421 ["New REPL" sly-mrepl-new ,C] 1422 ["Sync Package & Directory" sly-mrepl-sync 1423 (and sly-editing-mode ,C)]))) 1424 1425 (easy-menu-add-item sly-menu nil sly-mrepl--shortcut-menu "Documentation") 1426 1427 (easy-menu-define sly-mrepl--menu sly-mrepl-mode-map 1428 "Menu for SLY's MREPL" 1429 (let* ((C '(sly-connected-p))) 1430 `("SLY-mREPL" 1431 [ " Complete symbol at point " sly-mrepl-indent-and-complete-symbol ,C ] 1432 [ " Interrupt " sly-interrupt ,C ] 1433 [ " Isearch history backward " isearch-backward ,C] 1434 "----" 1435 [ " Clear REPL" sly-mrepl-clear-repl ,C ] 1436 [ " Clear last output" sly-mrepl-clear-recent-output ,C ]))) 1437 1438 1439 (defvar sly-mrepl--debug-overlays nil) 1440 1441 (defun sly-mrepl--debug (&rest ignored) 1442 (interactive) 1443 (mapc #'delete-overlay sly-mrepl--debug-overlays) 1444 (let ((overlay (make-overlay sly-mrepl--output-mark 1445 (sly-mrepl--mark))) 1446 (color (if (< sly-mrepl--output-mark (sly-mrepl--mark)) 1447 "green" 1448 "orange")) 1449 (marker-color (if (= sly-mrepl--output-mark (sly-mrepl--mark)) 1450 "red" 1451 "purple"))) 1452 (overlay-put overlay 1453 'face `(:background ,color)) 1454 (overlay-put overlay 1455 'after-string (propertize "F" 'face 1456 `(:background ,marker-color))) 1457 (push overlay sly-mrepl--debug-overlays))) 1458 1459 (defun sly-mrepl--turn-on-debug () 1460 (interactive) 1461 (add-hook 'after-change-functions 'sly-mrepl--debug nil 'local) 1462 (add-hook 'post-command-hook 'sly-mrepl--debug nil 'local)) 1463 1464 (defun sly-mrepl--turn-off-debug () 1465 (interactive) 1466 (remove-hook 'after-change-functions 'sly-mrepl--debug 'local) 1467 (remove-hook 'post-command-hook 'sly-mrepl--debug 'local)) 1468 1469 1470 ;;; A hack for Emacs Bug#32014 (Sly gh#165) 1471 ;;; 1472 (when (version<= "26.1" emacs-version) 1473 (advice-add 1474 #'lisp-indent-line 1475 :around 1476 (lambda (&rest args) 1477 (let ((beg (save-excursion (progn (beginning-of-line) (point))))) 1478 (cl-letf (((symbol-function #'indent-line-to) 1479 (lambda (indent) 1480 (let ((shift-amt (- indent (current-column)))) 1481 (if (zerop shift-amt) 1482 nil 1483 (delete-region beg (point)) 1484 (indent-to indent)))))) 1485 ;; call original 1486 (apply args)))) 1487 '((name . sly-workaround-for-emacs-bug-32014)))) 1488 1489 1490 ;;; Sylvesters 1491 ;;; 1492 (defvar sly-mrepl--sylvesters 1493 (with-temp-buffer 1494 (insert-file-contents-literally 1495 (expand-file-name "sylvesters.txt" 1496 (file-name-directory load-file-name))) 1497 (cl-loop while (< (point) (point-max)) 1498 for start = (point) 1499 do (search-forward "\n\n" nil 'noerror) 1500 collect (buffer-substring-no-properties start (- (point) 2))))) 1501 1502 (defun sly-mrepl-random-sylvester () 1503 (let* ((sylvester (nth (random (length sly-mrepl--sylvesters)) 1504 sly-mrepl--sylvesters)) 1505 (woe (sly-random-words-of-encouragement)) 1506 (uncommented 1507 (replace-regexp-in-string "@@@@" woe sylvester))) 1508 uncommented)) 1509 1510 (provide 'sly-mrepl)