sly-mrepl.el (64454B)
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 ;;;###autoload 973 (defun sly-mrepl (&optional display-action) 974 "Find or create the first useful REPL for the default connection. 975 If supplied, DISPLAY-ACTION is called on the 976 buffer. Interactively, DISPLAY-ACTION defaults to using 977 `switch-to-buffer' unless the intended buffer is already visible 978 in some window, in which case that window is selected." 979 (interactive (list (lambda (buf) 980 (let ((w (get-buffer-window buf))) 981 (if w (select-window w) (switch-to-buffer buf)))))) 982 (let* ((buffer 983 (sly-mrepl--find-create (sly-current-connection)))) 984 (when display-action 985 (funcall display-action buffer)) 986 buffer)) 987 988 (defun sly-mrepl-on-connection () 989 (let* ((inferior-buffer 990 (and (sly-process) (process-buffer (sly-process)))) 991 (inferior-window 992 (and inferior-buffer (get-buffer-window inferior-buffer t)))) 993 (let ((sly-mrepl-pop-sylvester 994 (or (eq sly-mrepl-pop-sylvester 'on-connection) 995 sly-mrepl-pop-sylvester))) 996 (sly-mrepl 'pop-to-buffer)) 997 (when inferior-window 998 (bury-buffer inferior-buffer) 999 (delete-window inferior-window)) 1000 (goto-char (point-max)))) 1001 1002 (defun sly-mrepl-new (connection &optional handle) 1003 "Create and setup a new REPL buffer for CONNECTION. 1004 CONNECTION defaults to the current SLY connection. If such a 1005 buffer already exists, or a prefix arg is given, prompt for a 1006 handle to distinguish the new buffer from the existing." 1007 (interactive 1008 ;; FIXME: Notice a subtle bug/feature than when calling 1009 ;; interactively in a buffer which has a connection, but not the 1010 ;; default connection, the new REPL will be for that connection. 1011 (let ((connection (sly-connection))) 1012 (list connection 1013 (if (or (get-buffer (sly-mrepl--buffer-name connection)) 1014 current-prefix-arg) 1015 (sly-read-from-minibuffer 1016 "Nickname for this new REPL? "))))) 1017 (let* ((name (sly-mrepl--buffer-name connection handle)) 1018 (existing (get-buffer name))) 1019 (when (and handle existing) 1020 (sly-user-error "A REPL with that handle already exists")) 1021 ;; Take this oportunity to save any other REPL histories so that 1022 ;; the new REPL will see them. 1023 (sly-mrepl--save-all-histories) 1024 (let* ((local (sly-make-channel sly-listener-channel-methods)) 1025 (buffer (pop-to-buffer name)) 1026 (default-directory (if (file-readable-p default-directory) 1027 default-directory 1028 (expand-file-name "~/")))) 1029 (with-current-buffer buffer 1030 (sly-mrepl-mode) 1031 (when (and (not existing) 1032 (eq sly-mrepl-pop-sylvester t)) 1033 (sly-mrepl--insert-note 1034 (concat "\n" (sly-mrepl-random-sylvester) "\n\n") 1035 'sly-mrepl-output-face)) 1036 (setq sly-buffer-connection connection) 1037 (start-process (format "sly-pty-%s-%s" 1038 (process-get connection 1039 'sly--net-connect-counter) 1040 (sly-channel.id local)) 1041 (current-buffer) 1042 nil) 1043 (set-process-query-on-exit-flag (sly-mrepl--process) nil) 1044 (setq header-line-format 1045 (format "Waiting for REPL creation ack for channel %d..." 1046 (sly-channel.id local))) 1047 (sly-channel-put local 'buffer (current-buffer)) 1048 (add-hook 'kill-buffer-hook 'sly-mrepl--teardown nil 'local) 1049 (set (make-local-variable 'sly-mrepl--local-channel) local)) 1050 (sly-eval-async 1051 `(slynk-mrepl:create-mrepl ,(sly-channel.id local)) 1052 (lambda (result) 1053 (cl-destructuring-bind (remote thread-id) result 1054 (with-current-buffer buffer 1055 (sly-mrepl--read-input-ring) 1056 (setq header-line-format nil) 1057 (setq sly-current-thread thread-id) 1058 (set (make-local-variable 'sly-mrepl--remote-channel) remote) 1059 (unwind-protect 1060 (run-hooks 'sly-mrepl-hook 'sly-mrepl-runonce-hook) 1061 (set-default 'sly-mrepl-runonce-hook nil)))))) 1062 buffer))) 1063 1064 (defun sly-mrepl-insert-input (pos) 1065 (interactive (list (if (mouse-event-p last-input-event) 1066 (posn-point (event-end last-input-event)) 1067 (point)))) 1068 (sly-mrepl--assert-mrepl) 1069 (let* ((pos (if (eq (field-at-pos pos) 'sly-mrepl-input) 1070 pos 1071 (1+ pos))) 1072 (new-input (and 1073 (eq (field-at-pos (1+ pos)) 'sly-mrepl-input) 1074 (field-string-no-properties pos))) 1075 (offset (and new-input 1076 (- (point) (field-beginning pos))))) 1077 (cond (new-input 1078 (goto-char (sly-mrepl--mark)) 1079 (delete-region (point) (point-max)) 1080 (insert (sly-trim-whitespace new-input)) 1081 (goto-char (+ (sly-mrepl--mark) offset))) 1082 (t 1083 (sly-user-error "No input at point"))))) 1084 1085 (defun sly-mrepl-guess-package (&optional point interactive) 1086 (interactive (list (point) t)) 1087 (let* ((point (or point (point))) 1088 (probe 1089 (previous-single-property-change point 1090 'sly-mrepl--prompt)) 1091 (package (and probe 1092 (or (get-text-property probe 'sly-mrepl--prompt) 1093 (let ((probe2 1094 (previous-single-property-change 1095 probe 'sly-mrepl--prompt))) 1096 (and probe2 1097 (get-text-property probe2 1098 'sly-mrepl--prompt))))))) 1099 (when interactive 1100 (sly-message "Guessed package \"%s\"" package)) 1101 package)) 1102 1103 (define-obsolete-function-alias 1104 'sly-mrepl-sync-package-and-default-directory 'sly-mrepl-sync 1105 "1.0.0-alpha-3") 1106 1107 (defun sly-mrepl-sync (&optional package directory expression) 1108 "Go to the REPL, and set Slynk's PACKAGE and DIRECTORY. 1109 Also yank EXPRESSION into the prompt. Interactively gather 1110 PACKAGE and DIRECTORY these values from the current buffer, if 1111 available. In this scenario EXPRESSION is only set if a C-u 1112 prefix argument is given." 1113 (interactive (list (sly-current-package) 1114 (and buffer-file-name 1115 default-directory) 1116 (and current-prefix-arg 1117 (sly-last-expression)))) 1118 (sly-mrepl--with-repl (sly-mrepl--find-create (sly-connection)) 1119 (when directory 1120 (cd directory)) 1121 (sly-mrepl--eval-for-repl 1122 `(slynk-mrepl:sync-package-and-default-directory 1123 :package-name ,package 1124 :directory ,(and directory 1125 (sly-to-lisp-filename directory))) 1126 :insert-p nil 1127 :before-prompt 1128 #'(lambda (results) 1129 (cl-destructuring-bind (package-2 directory-2) results 1130 (sly-mrepl--insert-note 1131 (cond ((and package directory) 1132 (format "Synched package to %s and directory to %s" 1133 package-2 directory-2)) 1134 (directory 1135 (format "Synched directory to %s" directory-2)) 1136 (package 1137 (format "Synched package to %s" package-2)) 1138 (t 1139 (format "Remaining in package %s and directory %s" 1140 package-2 directory-2)))))) 1141 :after-prompt 1142 #'(lambda (_results) 1143 (when expression 1144 (goto-char (point-max)) 1145 (let ((saved (point))) 1146 (insert expression) 1147 (when (string-match "\n" expression) 1148 (indent-region saved (point-max))))))))) 1149 1150 (defun sly-mrepl-clear-repl () 1151 "Clear all this REPL's output history. 1152 Doesn't clear input history." 1153 (interactive) 1154 (sly-mrepl--assert-mrepl) 1155 (sly-mrepl--send `(:clear-repl-history))) 1156 1157 (defun sly-mrepl-clear-recent-output () 1158 "Clear this REPL's output between current and last prompt." 1159 (interactive) 1160 (sly-mrepl--assert-mrepl) 1161 (cl-loop for search-start = 1162 (set-marker (make-marker) 1163 (1+ (overlay-start sly-mrepl--last-prompt-overlay))) 1164 then pos 1165 for pos = (set-marker 1166 search-start 1167 (previous-single-property-change search-start 'field)) 1168 while (and (marker-position pos) 1169 ;; FIXME: fragile (1- pos), use narrowing 1170 (not (get-text-property (1- pos) 'sly-mrepl--prompt)) 1171 (> pos (point-min))) 1172 when (eq (field-at-pos pos) 'sly-mrepl--output) 1173 do (let ((inhibit-read-only t)) 1174 (delete-region (field-beginning pos) 1175 (+ 1176 (if (eq ?\n (char-before (field-end pos))) 0 1) 1177 (field-end pos))) 1178 (sly-mrepl--insert-output "; Cleared last output" 1179 'sly-mrepl-note-face)) 1180 and return nil) 1181 (sly-message "Cleared last output")) 1182 1183 (defun sly-mrepl-next-prompt () 1184 "Go to the beginning of the next REPL prompt." 1185 (interactive) 1186 (let ((pos (next-single-char-property-change (line-beginning-position 2) 1187 'sly-mrepl--prompt))) 1188 (goto-char pos)) 1189 (end-of-line)) 1190 1191 (defun sly-mrepl-previous-prompt () 1192 "Go to the beginning of the previous REPL prompt." 1193 (interactive) 1194 ;; This has two wrinkles around the first prompt: (1) when going to 1195 ;; the first prompt it leaves point at column 0 (1) when called from 1196 ;; frist prompt goes to beginning of buffer. The correct fix is to 1197 ;; patch comint.el's comint-next-prompt and comint-previous-prompt 1198 ;; anyway... 1199 (let* ((inhibit-field-text-motion t) 1200 (pos (previous-single-char-property-change (1- (line-beginning-position)) 1201 'sly-mrepl--prompt))) 1202 (goto-char pos) 1203 (goto-char (line-beginning-position))) 1204 (end-of-line)) 1205 1206 1207 ;;; "External" non-interactive functions for plugging into 1208 ;;; other parts of SLY 1209 ;;; 1210 (defun sly-inspector-copy-part-to-repl (number) 1211 "Evaluate the inspector slot at point via the REPL (to set `*')." 1212 (sly-mrepl--save-and-copy-for-repl 1213 ;; FIXME: Using SLYNK:EVAL-FOR-INSPECTOR here repeats logic from 1214 ;; sly.el's `sly-eval-for-inspector', but we can't use that here 1215 ;; because we're already using `sly-mrepl--save-and-copy-for-repl'. 1216 ;; Investigate if these functions could maybe be macros instead. 1217 `(slynk:eval-for-inspector 1218 ,sly--this-inspector-name 1219 nil 1220 'slynk:inspector-nth-part-or-lose 1221 ,number) 1222 :before (format "Returning inspector slot %s" number))) 1223 1224 (defun sly-db-copy-part-to-repl (frame-id var-id) 1225 "Evaluate the frame var at point via the REPL (to set `*')." 1226 (sly-mrepl--save-and-copy-for-repl 1227 `(slynk-backend:frame-var-value ,frame-id ,var-id) 1228 :repl (sly-mrepl--find-buffer (sly-current-connection) sly-current-thread) 1229 :before (format "Returning var %s of frame %s" var-id frame-id))) 1230 1231 (defun sly-apropos-copy-symbol-to-repl (name _type) 1232 (sly-mrepl--save-and-copy-for-repl 1233 `(common-lisp:identity ',(car (read-from-string name))) 1234 :before (format "Returning symbol %s" name))) 1235 1236 (defun sly-trace-dialog-copy-part-to-repl (id part-id type) 1237 "Eval the Trace Dialog entry under point in the REPL (to set *)" 1238 (sly-mrepl--save-and-copy-for-repl 1239 `(slynk-trace-dialog:trace-part-or-lose ,id ,part-id ,type) 1240 :before (format "Returning part %s (%s) of trace entry %s" part-id type id))) 1241 1242 (defun sly-db-copy-call-to-repl (frame-id spec) 1243 (sly-mrepl--save-and-copy-for-repl 1244 `(slynk-backend:frame-arguments ,frame-id) 1245 :before (format "The actual arguments passed to frame %s" frame-id) 1246 :after #'(lambda (objects) 1247 (sly-mrepl--insert-call spec objects)))) 1248 1249 (defun sly-trace-dialog-copy-call-to-repl (trace-id spec) 1250 (sly-mrepl--save-and-copy-for-repl 1251 `(slynk-trace-dialog:trace-arguments-or-lose ,trace-id) 1252 :before (format "The actual arguments passed to trace %s" trace-id) 1253 :after #'(lambda (objects) 1254 (sly-mrepl--insert-call spec objects)))) 1255 1256 (defun sly-mrepl-inside-string-or-comment-p () 1257 (let ((mark (and (process-live-p (sly-mrepl--process)) 1258 (sly-mrepl--mark)))) 1259 (when (and mark (> (point) mark)) 1260 (let ((ppss (parse-partial-sexp mark (point)))) 1261 (or (nth 3 ppss) (nth 4 ppss)))))) 1262 1263 1264 ;;; The comma shortcut 1265 ;;; 1266 (defvar sly-mrepl-shortcut-history nil "History for sly-mrepl-shortcut.") 1267 1268 (defun sly-mrepl-reset-shortcut (key-sequence) 1269 "Set `sly-mrepl-shortcut' and reset REPL keymap accordingly." 1270 (interactive "kNew shortcut key sequence? ") 1271 (when (boundp 'sly-mrepl-shortcut) 1272 (define-key sly-mrepl-mode-map sly-mrepl-shortcut nil)) 1273 (set-default 'sly-mrepl-shortcut key-sequence) 1274 (define-key sly-mrepl-mode-map key-sequence 1275 '(menu-item "" sly-mrepl-shortcut 1276 :filter (lambda (cmd) 1277 (if (and (eq major-mode 'sly-mrepl-mode) 1278 (sly-mrepl--shortcut-location-p)) 1279 cmd))))) 1280 1281 (defcustom sly-mrepl-shortcut (kbd ",") 1282 "Keybinding string used for the REPL shortcut commands. 1283 When setting this variable outside of the Customize interface, 1284 `sly-mrepl-reset-shortcut' must be used." 1285 :group 'sly 1286 :type 'key-sequence 1287 :set (lambda (_sym value) 1288 (sly-mrepl-reset-shortcut value))) 1289 1290 (defun sly-mrepl--shortcut-location-p () 1291 (or (< (point) (sly-mrepl--mark)) 1292 (and (not (let ((state (syntax-ppss))) 1293 (or (nth 3 state) (nth 4 state)))) 1294 (or (not (equal sly-mrepl-shortcut ",")) 1295 (not (save-excursion 1296 (search-backward "`" (sly-mrepl--mark) 'noerror))))))) 1297 1298 (defvar sly-mrepl-shortcut-alist 1299 ;; keep this alist ordered by the key value, in order to make it easier to see 1300 ;; the identifying prefixes and keep them short 1301 '(("cd" . sly-mrepl-set-directory) 1302 ("clear repl" . sly-mrepl-clear-repl) 1303 ("disconnect" . sly-disconnect) 1304 ("disconnect all" . sly-disconnect-all) 1305 ("in-package" . sly-mrepl-set-package) 1306 ("restart lisp" . sly-restart-inferior-lisp) 1307 ("quit lisp" . sly-quit-lisp) 1308 ("sayoonara" . sly-quit-lisp) 1309 ("set directory" . sly-mrepl-set-directory) 1310 ("set package" . sly-mrepl-set-package))) 1311 1312 1313 (defun sly-mrepl-set-package () 1314 (interactive) 1315 (let ((package (sly-read-package-name "New package: "))) 1316 (sly-mrepl--eval-for-repl `(slynk-mrepl:guess-and-set-package ,package)))) 1317 1318 (defun sly-mrepl-set-directory () 1319 (interactive) 1320 (let ((dir (read-directory-name "New directory: " 1321 default-directory nil t))) 1322 ;; repeats logic in `sly-cd'. 1323 (sly-mrepl--eval-for-repl 1324 `(slynk:set-default-directory 1325 (slynk-backend:filename-to-pathname 1326 ,(sly-to-lisp-filename dir)))) 1327 (sly-mrepl--insert-note (format "Setting directory to %s" dir)) 1328 (cd dir))) 1329 1330 (advice-add 1331 'sly-cd :around 1332 (lambda (oldfun r) 1333 (interactive (lambda (oldspec) 1334 (if (or (not (eq major-mode 'sly-mrepl-mode)) 1335 (sly-y-or-n-p 1336 (substitute-command-keys 1337 "This won't set the REPL's directory (use \ 1338 \\[sly-mrepl-set-directory] for that). Proceed?"))) 1339 (list (advice-eval-interactive-spec oldspec)) 1340 (keyboard-quit)))) 1341 (apply oldfun r)) 1342 '((name . sly-mrepl--be-aware-of-sly-cd))) 1343 1344 (defun sly-mrepl-shortcut () 1345 (interactive) 1346 (let* ((string (completing-read "Command: " 1347 (mapcar #'car sly-mrepl-shortcut-alist) 1348 nil 'require-match nil 1349 'sly-mrepl-shortcut-history 1350 (car sly-mrepl-shortcut-history))) 1351 (command (and string 1352 (cdr (assoc string sly-mrepl-shortcut-alist))))) 1353 (call-interactively command))) 1354 1355 1356 ;;; Backreference highlighting 1357 ;;; 1358 (defvar sly-mrepl--backreference-overlays nil 1359 "List of overlays on top of REPL result buttons.") 1360 (make-variable-buffer-local 'sly-mrepl--backreference-overlays) 1361 1362 (defun sly-mrepl-highlight-results (&optional entry-idx value-idx) 1363 "Highlight REPL results for ENTRY-IDX and VALUE-IDX. 1364 If VALUE-IDX is nil or `all', highlight all results for entry 1365 ENTRY-IDX. If ENTRY-IDX is nil, highlight all results. Returns 1366 a list of result buttons thus highlighted" 1367 (interactive) 1368 (cl-loop 1369 for button in (sly-button-buttons-in (point-min) (point-max)) 1370 for e-idx = (car (button-get button 'part-args)) 1371 for v-idx = (cadr (button-get button 'part-args)) 1372 when (and (button-type-subtype-p (button-type button) 'sly-mrepl-part) 1373 (eq (button-get button 'sly-connection) (sly-current-connection)) 1374 (not (button-get button 'sly-mrepl--highlight-overlay)) 1375 (and (or (not entry-idx) 1376 (= e-idx entry-idx)) 1377 (or (not value-idx) 1378 (eq value-idx 'all) 1379 (= v-idx value-idx)))) 1380 collect button and 1381 do (let ((overlay (make-overlay (button-start button) (button-end button)))) 1382 (push overlay sly-mrepl--backreference-overlays) 1383 (overlay-put overlay 'before-string 1384 (concat 1385 (propertize 1386 (format "%s:%s" 1387 (car (button-get button 'part-args)) 1388 (cadr (button-get button 'part-args))) 1389 'face 'highlight) 1390 " "))))) 1391 1392 (defun sly-mrepl-unhighlight-results () 1393 "Unhighlight all repl results" 1394 (interactive) 1395 (mapc #'delete-overlay sly-mrepl--backreference-overlays) 1396 (setq sly-mrepl--backreference-overlays nil)) 1397 1398 (defvar sly-mrepl--backreference-overlay nil) 1399 (defvar sly-mrepl--backreference-prefix "#v") 1400 1401 (defun sly-mrepl--highlight-backreferences-maybe () 1402 "Intended to be placed in `post-command-hook'." 1403 (sly-mrepl-unhighlight-results) 1404 (when sly-mrepl--backreference-overlay 1405 (delete-overlay sly-mrepl--backreference-overlay)) 1406 (let* ((match (save-excursion 1407 (sly-beginning-of-symbol) 1408 (looking-at 1409 (format "%s\\([[:digit:]]+\\)?\\(:\\([[:digit:]]+\\)\\|:\\)?" 1410 sly-mrepl--backreference-prefix)))) 1411 (m0 (and match (match-string 0))) 1412 (m1 (and m0 (match-string 1))) 1413 (m2 (and m1 (match-string 2))) 1414 (m3 (and m2 (match-string 3))) 1415 (entry-idx (and m1 (string-to-number m1))) 1416 (value-idx (and match 1417 (or (and m3 (string-to-number m3)) 1418 (and (not m2) 1419 'all))))) 1420 (if (null match) 1421 (set (make-local-variable 'sly-autodoc-preamble) nil) 1422 (let ((buttons (sly-mrepl-highlight-results entry-idx value-idx)) 1423 (overlay 1424 (or sly-mrepl--backreference-overlay 1425 (set (make-local-variable 'sly-mrepl--backreference-overlay) 1426 (make-overlay 0 0)))) 1427 (message-log-max nil) 1428 (message-text)) 1429 (move-overlay sly-mrepl--backreference-overlay 1430 (match-beginning 0) (match-end 0)) 1431 (cond 1432 ((null buttons) 1433 (overlay-put overlay 'face 'font-lock-warning-face) 1434 (setq message-text (format "No history references for backreference `%s'" m0))) 1435 ((and buttons 1436 entry-idx 1437 value-idx) 1438 (overlay-put overlay 'face 'sly-action-face) 1439 (let* ((prefix (if (numberp value-idx) 1440 (format "Matched history value %s of entry %s: " 1441 value-idx 1442 entry-idx) 1443 (format "Matched history entry %s%s: " 1444 entry-idx 1445 (if (cl-rest buttons) 1446 (format " (%s values)" (length buttons)) 1447 "")))) 1448 (hint (propertize 1449 (truncate-string-to-width 1450 (replace-regexp-in-string "\n" " " 1451 (button-label 1452 (cl-first buttons))) 1453 (- (window-width (minibuffer-window)) 1454 (length prefix) 10) 1455 nil 1456 nil 1457 "...") 1458 'face 1459 'sly-action-face))) 1460 (setq message-text (format "%s" (format "%s%s" prefix hint))))) 1461 (buttons 1462 (setq message-text (format "Ambiguous backreference `%s', %s values possible" 1463 m0 (length buttons))) 1464 (overlay-put overlay 'face 'font-lock-warning-face)) 1465 (t 1466 (overlay-put overlay 'face 'font-lock-warning-face) 1467 (setq message-text (format "Invalid backreference `%s'" m0)))) 1468 (sly-message "%s" message-text) 1469 (set (make-local-variable 'sly-autodoc-preamble) message-text))))) 1470 1471 1472 ;;;; Menu 1473 ;;;; 1474 (easy-menu-define sly-mrepl--shortcut-menu nil 1475 "Menu for accessing the mREPL anywhere in sly." 1476 (let* ((C '(sly-connected-p))) 1477 `("mREPL" 1478 ["Go to default REPL" sly-mrepl ,C] 1479 ["New REPL" sly-mrepl-new ,C] 1480 ["Sync Package & Directory" sly-mrepl-sync 1481 (and sly-editing-mode ,C)]))) 1482 1483 (easy-menu-add-item sly-menu nil sly-mrepl--shortcut-menu "Documentation") 1484 1485 (easy-menu-define sly-mrepl--menu sly-mrepl-mode-map 1486 "Menu for SLY's MREPL" 1487 (let* ((C '(sly-connected-p))) 1488 `("SLY-mREPL" 1489 [ " Complete symbol at point " sly-mrepl-indent-and-complete-symbol ,C ] 1490 [ " Interrupt " sly-interrupt ,C ] 1491 [ " Isearch history backward " isearch-backward ,C] 1492 "----" 1493 [ " Clear REPL" sly-mrepl-clear-repl ,C ] 1494 [ " Clear last output" sly-mrepl-clear-recent-output ,C ]))) 1495 1496 1497 (defvar sly-mrepl--debug-overlays nil) 1498 1499 (defun sly-mrepl--debug (&rest ignored) 1500 (interactive) 1501 (mapc #'delete-overlay sly-mrepl--debug-overlays) 1502 (let ((overlay (make-overlay sly-mrepl--output-mark 1503 (sly-mrepl--mark))) 1504 (color (if (< sly-mrepl--output-mark (sly-mrepl--mark)) 1505 "green" 1506 "orange")) 1507 (marker-color (if (= sly-mrepl--output-mark (sly-mrepl--mark)) 1508 "red" 1509 "purple"))) 1510 (overlay-put overlay 1511 'face `(:background ,color)) 1512 (overlay-put overlay 1513 'after-string (propertize "F" 'face 1514 `(:background ,marker-color))) 1515 (push overlay sly-mrepl--debug-overlays))) 1516 1517 (defun sly-mrepl--turn-on-debug () 1518 (interactive) 1519 (add-hook 'after-change-functions 'sly-mrepl--debug nil 'local) 1520 (add-hook 'post-command-hook 'sly-mrepl--debug nil 'local)) 1521 1522 (defun sly-mrepl--turn-off-debug () 1523 (interactive) 1524 (remove-hook 'after-change-functions 'sly-mrepl--debug 'local) 1525 (remove-hook 'post-command-hook 'sly-mrepl--debug 'local)) 1526 1527 1528 ;;; A hack for Emacs Bug#32014 (Sly gh#165) 1529 ;;; 1530 (when (version<= "26.1" emacs-version) 1531 (advice-add 1532 #'lisp-indent-line 1533 :around 1534 (lambda (&rest args) 1535 (let ((beg (save-excursion (progn (beginning-of-line) (point))))) 1536 (cl-letf (((symbol-function #'indent-line-to) 1537 (lambda (indent) 1538 (let ((shift-amt (- indent (current-column)))) 1539 (if (zerop shift-amt) 1540 nil 1541 (delete-region beg (point)) 1542 (indent-to indent)))))) 1543 ;; call original 1544 (apply args)))) 1545 '((name . sly-workaround-for-emacs-bug-32014)))) 1546 1547 1548 ;;; Sylvesters 1549 ;;; 1550 (defvar sly-mrepl--sylvesters 1551 (with-temp-buffer 1552 (insert-file-contents-literally 1553 (expand-file-name "sylvesters.txt" 1554 (file-name-directory load-file-name))) 1555 (cl-loop while (< (point) (point-max)) 1556 for start = (point) 1557 do (search-forward "\n\n" nil 'noerror) 1558 collect (buffer-substring-no-properties start (- (point) 2))))) 1559 1560 (defun sly-mrepl-random-sylvester () 1561 (let* ((sylvester (nth (random (length sly-mrepl--sylvesters)) 1562 sly-mrepl--sylvesters)) 1563 (woe (sly-random-words-of-encouragement)) 1564 (uncommented 1565 (replace-regexp-in-string "@@@@" woe sylvester))) 1566 uncommented)) 1567 1568 (provide 'sly-mrepl)