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