slynk-mrepl.lisp (31572B)
1 ;;; slynk-mrepl.lisp 2 ;; 3 ;; Licence: public domain 4 5 (defpackage :slynk-mrepl 6 (:use :cl :slynk-api) 7 (:import-from :slynk 8 #:*globally-redirect-io* 9 #:*use-dedicated-output-stream* 10 #:*dedicated-output-stream-port* 11 #:*dedicated-output-stream-buffering*) 12 (:export #:create-mrepl 13 #:globally-save-object 14 #:eval-for-mrepl 15 #:sync-package-and-default-directory 16 #:pprint-entry 17 #:inspect-entry 18 #:guess-and-set-package 19 #:copy-to-repl 20 #:describe-entry 21 #:send-prompt 22 #:copy-to-repl-in-emacs)) 23 (in-package :slynk-mrepl) 24 25 26 ;;; MREPL models 27 (defclass mrepl (channel listener) 28 ((remote-id :initarg :remote-id :accessor mrepl-remote-id) 29 (mode :initform :eval :accessor mrepl-mode) 30 (pending-errors :initform nil :accessor mrepl-pending-errors)) 31 (:documentation "A listener implemented in terms of a channel.") 32 (:default-initargs 33 :initial-env (copy-tree ; github#626 34 `((cl:*package* . ,cl:*package*) 35 (cl:*default-pathname-defaults* 36 . ,cl:*default-pathname-defaults*) 37 (*) (**) (***) 38 (/) (//) (///) 39 (+) (++) (+++) 40 (*history* . ,(make-array 40 :fill-pointer 0 41 :adjustable t)))))) 42 43 (defmethod print-object ((r mrepl) stream) 44 (print-unreadable-object (r stream :type t) 45 (format stream "mrepl-~a-~a" (channel-id r) (mrepl-remote-id r)))) 46 47 (defmethod initialize-instance :before ((r mrepl) &key) 48 (setf (slot-value r 'slynk::in) (make-mrepl-input-stream r))) 49 50 51 ;;; Helpers 52 ;;; 53 (defvar *history* nil) 54 55 (defvar *saved-objects* nil) 56 57 (defmethod slynk::drop-unprocessed-events ((r mrepl)) 58 "Empty REPL of events, then send prompt to Emacs." 59 ;; FIXME: Dropping events should be moved to the library, and this 60 ;; :DROP nonsense dropped, hence the deliberate SLYNK::. 61 (with-slots (mode) r 62 (let ((old-mode mode)) 63 (setf mode :drop) 64 (unwind-protect 65 (process-requests t) 66 (setf mode old-mode))))) 67 68 (defun mrepl-get-history-entry (entry-idx) 69 (let ((len (length *history*))) 70 (assert (and entry-idx 71 (integerp entry-idx) 72 (< -1 entry-idx len)) 73 nil 74 "Illegal history entry ~a for ~a-long history" 75 entry-idx 76 len) 77 (aref *history* entry-idx))) 78 79 (defun mrepl-get-object-from-history (entry-idx &optional value-idx) 80 (let* ((entry (mrepl-get-history-entry entry-idx)) 81 (len (length entry))) 82 (assert (or (not value-idx) 83 (and (integerp value-idx) 84 (< -1 value-idx len))) 85 nil 86 "History entry ~a is only ~a elements long." 87 entry-idx 88 len 89 value-idx) 90 (if (numberp value-idx) 91 (nth value-idx entry) 92 (values-list entry)))) 93 94 (defparameter *backreference-character* #\v 95 "Character used for #v<entry>:<value> backreferences in the REPL. 96 Set this to some other value if it conflicts with some other reader 97 macro that you wish to use in the REPL. 98 Set this to NIL to turn this feature off.") 99 100 (defun backreference-reader (stream subchar arg) 101 "Reads #rfoo:bar into (MREPL-GET-OBJECT-FROM-HISTORY foo bar)." 102 (declare (ignore subchar arg)) 103 (let* ((*readtable* 104 (let ((table (copy-readtable nil))) 105 (set-macro-character #\: (lambda (&rest args) nil) nil table) 106 table)) 107 (entry-idx 108 (progn 109 (when (eq #\: (peek-char nil stream nil nil)) 110 (error 'reader-error 111 :stream stream 112 :format-control "~a found in unexpected place in ~a" 113 :format-arguments `(#\: backreference-reader))) 114 (read-preserving-whitespace stream))) 115 (value-idx (progn 116 (and (eq #\: (peek-char nil stream nil nil)) 117 (read-char stream) 118 (read stream))))) 119 `(mrepl-get-object-from-history 120 ,entry-idx ,value-idx))) 121 122 #+nil 123 (defun backreference-reader-tests () 124 (let ((expectations 125 '(("#v:something" error) 126 ("#vnotanumber:something" (notanumber something)) 127 ("#vnotanumber" (notanumber nil)) 128 ("#v2 :something" (2 nil) :something) 129 ("#v2:99 :something-else" (2 99) :something-else))) 130 (*readtable* (let ((table (copy-readtable))) 131 (if *backreference-character* 132 (set-dispatch-macro-character 133 #\# 134 *backreference-character* 135 #'backreference-reader table)) 136 table))) 137 (loop for (input expected-spec following) in expectations 138 collect 139 (handler-case 140 (progn 141 (with-input-from-string (s input) 142 (let* ((observed (read s)) 143 (expected 144 (progn 145 (if (eq 'error expected-spec ) 146 (error "oops, ~a was supposed to have errored, but returned ~a" 147 input observed)) 148 `(mrepl-get-object-from-history ,@expected-spec))) 149 (observed-second (and following 150 (read s)))) 151 (unless (equal observed expected) 152 (error "oops, ~a was supposed to have returned ~a, but returned ~a" 153 input expected observed)) 154 (unless (equal observed-second following) 155 (error "oops, ~a was have read ~a after, but read ~a" 156 input following observed-second)) 157 (list observed observed-second)))) 158 (reader-error (e) 159 (unless (eq 'error expected-spec) 160 (error "oops, ~a wasn't supposed to error with ~a" input e))))))) 161 162 (defun make-results (objects) 163 (loop for value in objects 164 collect (list (present-for-emacs value #'slynk-pprint) 165 (1- (length *history*)) 166 (cond ((symbolp value) 167 (with-output-to-string (s) 168 (unless (keywordp value) (princ "'" s)) 169 (write value :stream s :case :downcase))) 170 ((numberp value) 171 (princ-to-string value)))))) 172 173 (defun mrepl-eval (repl string) 174 (let ((aborted t) 175 (results) 176 (error-prompt-sent)) 177 (setf (mrepl-mode repl) :busy) 178 (unwind-protect 179 (let* ((previous-hook *debugger-hook*) 180 (*debugger-hook* 181 ;; Here's how this debugger hook handles "debugger 182 ;; levels". 183 ;; 184 ;; (1) This very lambda may be called multiple 185 ;; times, but *not recursively, for the same 186 ;; MREPL-EVAL call. That is becasue because SLY's 187 ;; top-level debugger hook enters a blocking 188 ;; SLY-DB-LOOP, and letting users invoke all manners 189 ;; of restarts established in the code they wants us 190 ;; to evaluate. It's important that we mark the 191 ;; condition that led to the debugger only once, in 192 ;; the ERRORRED var. On that occasion, we also send 193 ;; a prompt to the REPL and increase the debugger 194 ;; level. If the user selects a restart that 195 ;; re-runs (but *not* recursively) this very lambda, 196 ;; we do *not* want to send a prompt again. 197 ;; 198 ;; (2) This lambda may also run multiple times, but 199 ;; recursively, in the very special case of nested 200 ;; MREPL-EVAL may be nested (if the program calls 201 ;; PROCESS-REQUESTS explicitly e.g.). We 202 ;; (hackishly) detect this case by checking by 203 ;; checking the car of MREPL-PENDING-ERRORS. In 204 ;; that case, we are sure that calling previous hook 205 ;; (which is a different copy of this very lambda 206 ;; but running in a different stack frame) will take 207 ;; care of the prompt sending and error management 208 ;; for us, so we just do that. 209 (lambda (condition hook) 210 (setq aborted condition) 211 (cond ((eq condition (car (mrepl-pending-errors repl))) 212 (funcall previous-hook condition hook)) 213 (t 214 (push condition (mrepl-pending-errors repl)) 215 (unless error-prompt-sent 216 (setq error-prompt-sent t) 217 (with-listener-bindings repl 218 (send-prompt repl condition))) 219 (unwind-protect 220 (funcall previous-hook condition hook) 221 (pop (mrepl-pending-errors repl)))))))) 222 (setq results (mrepl-eval-1 repl string) 223 ;; If somehow the form above MREPL-EVAL-1 exited 224 ;; normally, set ABORTED to nil 225 aborted nil)) 226 (unless (eq (mrepl-mode repl) :teardown) 227 (flush-listener-streams repl) 228 (saving-listener-bindings repl 229 (cond (aborted 230 (send-to-remote-channel (mrepl-remote-id repl) 231 `(:evaluation-aborted 232 ,(slynk::without-printing-errors 233 (:object aborted :stream nil) 234 (prin1-to-string aborted))))) 235 (t 236 (when results 237 (setq /// // // / / results 238 *** ** ** * * (car results)) 239 (vector-push-extend results *history*)) 240 (send-to-remote-channel 241 (mrepl-remote-id repl) 242 `(:write-values ,(make-results results))))) 243 (send-prompt repl)))))) 244 245 (defun prompt-arguments (repl condition) 246 "Return (PACKAGE NICKNAME ELEVEL ENTRY-IDX &optional CONDITION)" 247 `(,(package-name *package*) 248 ,(package-string-for-prompt *package*) 249 ,(length (mrepl-pending-errors repl)) 250 ,(length *history*) 251 ,@(when condition 252 (list (write-to-string condition 253 :escape t 254 :readably nil))))) 255 256 (defun send-prompt (&optional (repl *channel*) condition) 257 (send-to-remote-channel (mrepl-remote-id repl) 258 `(:prompt ,@(prompt-arguments repl condition))) 259 (setf (mrepl-mode repl) :eval)) 260 261 (defun mrepl-eval-1 (repl string) 262 "In REPL's environment, READ and EVAL forms in STRING." 263 (with-sly-interrupts 264 ;; Use WITH-LISTENER-BINDINGS (not SAVING-LISTENER-BINDINGS) 265 ;; instead, otherwise, if EVAL pops up an error in STRING's form, 266 ;; and in the meantime we had some debugging prompts (which make 267 ;; recursive calls to this function), the variables *, **, *** and 268 ;; *HISTORY* will get incorrectly clobbered to their pre-debugger 269 ;; values, whereas we want to serialize this history. 270 ;; 271 ;; However, as an exception, we /do/ want /some/ special symbols 272 ;; to be clobbered if the evaluation of STRING eventually 273 ;; completes. Currently, those are *PACKAGE* and 274 ;; *DEFAULT-PATHNAME-DEFAULTS*. 275 ;; 276 ;; Another way to see this is: the forms that the user inputs can 277 ;; only change binding of those special symbols in the listener's 278 ;; environment. Everything else in there is handled automatically. 279 ;; 280 (with-listener-bindings repl 281 (prog1 282 (with-retry-restart (:msg "Retry SLY mREPL evaluation request.") 283 (with-input-from-string (in string) 284 (loop with values 285 for form = 286 (let ((*readtable* (let ((table (copy-readtable))) 287 (if *backreference-character* 288 (set-dispatch-macro-character 289 #\# 290 *backreference-character* 291 #'backreference-reader table)) 292 table))) 293 (read in nil in)) 294 until (eq form in) 295 do (let ((- form)) 296 (setq values (multiple-value-list 297 (eval 298 (saving-listener-bindings repl 299 (setq +++ ++ ++ + + form)))))) 300 finally 301 (return values)))) 302 (dolist (special-sym '(*package* *default-pathname-defaults*)) 303 (setf (cdr (assoc special-sym (slot-value repl 'slynk::env))) 304 (symbol-value special-sym))))))) 305 306 (defun set-external-mode (repl new-mode) 307 (with-slots (mode remote-id) repl 308 (unless (eq mode new-mode) 309 (send-to-remote-channel remote-id `(:set-read-mode ,new-mode))) 310 (setf mode new-mode))) 311 312 (defun read-input (repl) 313 (with-slots (mode remote-id) repl 314 ;; shouldn't happen with slynk-gray.lisp, they use locks 315 (assert (not (eq mode :read)) nil "Cannot pipeline READs") 316 (let ((tid (slynk-backend:thread-id (slynk-backend:current-thread))) 317 (old-mode mode)) 318 (unwind-protect 319 (cond ((and (eq (channel-thread-id repl) tid) 320 (eq mode :busy)) 321 (flush-listener-streams repl) 322 (set-external-mode repl :read) 323 (unwind-protect 324 (catch 'mrepl-read (process-requests nil)) 325 (set-external-mode repl :finished-reading))) 326 (t 327 (setf mode :read) 328 (with-output-to-string (s) 329 (format s 330 (or (slynk::read-from-minibuffer-in-emacs 331 (format nil "Input for thread ~a? " tid)) 332 (error "READ for thread ~a interrupted" tid))) 333 (terpri s)))) 334 (setf mode old-mode))))) 335 336 337 ;;; Channel methods 338 ;;; 339 (define-channel-method :inspect-object ((r mrepl) entry-idx value-idx) 340 (with-listener-bindings r 341 (send-to-remote-channel 342 (mrepl-remote-id r) 343 `(:inspect-object 344 ,(slynk::inspect-object 345 (mrepl-get-object-from-history entry-idx value-idx)))))) 346 347 (define-channel-method :process ((c mrepl) string) 348 (with-slots (mode) c 349 (case mode 350 (:eval (mrepl-eval c string)) 351 (:read (throw 'mrepl-read string)) 352 (:drop)))) 353 354 (define-channel-method :teardown ((r mrepl)) 355 ;; FIXME: this should be a `:before' spec and closing the channel in 356 ;; slynk.lisp's :teardown method should suffice. 357 ;; 358 (setf (mrepl-mode r) :teardown) 359 (call-next-method)) 360 361 (define-channel-method :clear-repl-history ((r mrepl)) 362 (saving-listener-bindings r 363 ;; FIXME: duplication... use reinitialize-instance 364 (setf *history* (make-array 40 :fill-pointer 0 365 :adjustable t) 366 * nil ** nil *** nil 367 + nil ++ nil +++ nil 368 / nil // nil /// nil) 369 (send-to-remote-channel (mrepl-remote-id r) `(:clear-repl-history)) 370 (send-prompt r))) 371 372 373 ;;; slyfuns 374 ;;; 375 (defslyfun create-mrepl (remote-id) 376 (let* ((mrepl (make-instance 377 'mrepl 378 :remote-id remote-id 379 :name (format nil "mrepl-remote-~a" remote-id) 380 :out (make-mrepl-output-stream remote-id)))) 381 (let ((target (maybe-redirect-global-io *emacs-connection*))) 382 (saving-listener-bindings mrepl 383 (format *standard-output* "~&; SLY ~a (~a)~%" 384 *slynk-wire-protocol-version* 385 mrepl) 386 (cond 387 ((and target 388 (not (eq mrepl target))) 389 (format *standard-output* "~&; Global redirection setup elsewhere~%")) 390 ((not target) 391 (format *standard-output* "~&; Global redirection not setup~%")))) 392 (flush-listener-streams mrepl) 393 (send-prompt mrepl) 394 (list (channel-id mrepl) (channel-thread-id mrepl))))) 395 396 (defslyfun globally-save-object (slave-slyfun &rest args) 397 "Apply SLYFUN to ARGS and save the value. 398 The saved value should be visible to all threads and retrieved via 399 the COPY-TO-REPL slyfun." 400 (setq *saved-objects* (multiple-value-list (apply slave-slyfun args))) 401 t) 402 403 (defun copy-to-repl-in-emacs (values &key 404 (blurb "Here are some values") 405 (pop-to-buffer t)) 406 "Copy any user object to SLY's REPL. Requires 407 `sly-enable-evaluate-in-emacs' to be true." 408 (with-connection ((default-connection)) 409 (apply #'slynk-mrepl:globally-save-object #'cl:values values) 410 (slynk:eval-in-emacs `(sly-mrepl--copy-globally-saved-to-repl 411 :before ,blurb :pop-to-buffer ,pop-to-buffer)) 412 t)) 413 414 (defmacro with-eval-for-repl ((remote-id &optional mrepl-sym 415 update-mrepl) &body body) 416 (let ((mrepl-sym (or mrepl-sym 417 (gensym)))) 418 `(let ((,mrepl-sym (find-channel ,remote-id))) 419 (assert ,mrepl-sym) 420 (assert 421 (eq (slynk-backend:thread-id 422 (slynk-backend:current-thread)) 423 (channel-thread-id ,mrepl-sym)) 424 nil 425 "This SLYFUN can only be called from threads belonging to MREPL") 426 ,(if update-mrepl 427 `(saving-listener-bindings ,mrepl-sym 428 ,@body) 429 `(with-listener-bindings ,mrepl-sym 430 ,@body))))) 431 432 (defslyfun eval-for-mrepl (remote-id slave-slyfun &rest args) 433 "A synchronous form for evaluation in the mREPL context. 434 435 Calls SLAVE-SLYFUN with ARGS in the MREPL of REMOTE-ID. Both the 436 target MREPL's thread and environment are considered. 437 438 SLAVE-SLYFUN is typically destructive to the REPL listener's 439 environment. 440 441 This function returns a list of two elements. The first is a list 442 of arguments as sent in the :PROMPT channel method reply. The second 443 is the values list returned by SLAVE-SLYFUN transformed into a normal 444 list." 445 (with-eval-for-repl (remote-id mrepl 'allow-destructive) 446 (let ((objects (multiple-value-list (apply slave-slyfun args)))) 447 (list 448 (prompt-arguments mrepl nil) 449 objects)))) 450 451 (defslyfun inspect-entry (remote-id entry-idx value-idx) 452 (with-eval-for-repl (remote-id) 453 (slynk::inspect-object 454 (mrepl-get-object-from-history entry-idx value-idx)))) 455 456 (defslyfun describe-entry (remote-id entry-idx value-idx) 457 (with-eval-for-repl (remote-id) 458 (slynk::describe-to-string 459 (mrepl-get-object-from-history entry-idx value-idx)))) 460 461 (defslyfun pprint-entry (remote-id entry-idx value-idx) 462 (with-eval-for-repl (remote-id) 463 (slynk::slynk-pprint 464 (list (mrepl-get-object-from-history entry-idx value-idx))))) 465 466 467 ;;; "Slave" slyfuns. 468 ;;; 469 ;;; These are slyfuns intented to be called as the SLAVE-SLYFUN 470 ;;; argument of EVAL-FOR-MREPL. 471 ;;; 472 473 (defslyfun guess-and-set-package (package-name) 474 (let ((package (slynk::guess-package package-name))) 475 (if package 476 (setq *package* package) 477 (error "Can't find a package for designator ~a" package-name)) 478 t)) 479 480 (defslyfun copy-to-repl (&optional entry-idx value-idx) 481 "Recall objects in *HISTORY* or *SAVED-OBJECTS* as the last entry." 482 (let ((objects 483 (cond ((and entry-idx value-idx) 484 (list (mrepl-get-object-from-history entry-idx value-idx))) 485 (entry-idx 486 (mrepl-get-history-entry entry-idx)) 487 (value-idx 488 (error "Doesn't make sense")) 489 (t 490 *saved-objects*)))) 491 (setq /// // // / / objects 492 *** ** ** * * (car objects)) 493 (vector-push-extend objects *history*) 494 (values-list (make-results objects)))) 495 496 (defslyfun sync-package-and-default-directory (&key package-name directory) 497 (when directory 498 (slynk:set-default-directory directory)) 499 (when package-name 500 (guess-and-set-package package-name)) 501 (values (package-name *package*) (slynk-backend:default-directory))) 502 503 504 ;;;; Dedicated stream 505 ;;;; 506 (defvar *use-dedicated-output-stream* :started-from-emacs 507 "When T, dedicate a second stream for sending output to Emacs.") 508 509 (defvar *dedicated-output-stream-port* 0 510 "Which port we should use for the dedicated output stream.") 511 512 (defvar *dedicated-output-stream-buffering* 513 (if (eq slynk:*communication-style* :spawn) :line nil) 514 "The buffering scheme that should be used for the output stream. 515 Be advised that some Lisp backends don't support this. 516 Valid values are nil, t, :line.") 517 518 (defun use-dedicated-output-stream-p () 519 (case *use-dedicated-output-stream* 520 (:started-from-emacs slynk-api:*m-x-sly-from-emacs*) 521 (t *use-dedicated-output-stream*))) 522 523 (defun make-mrepl-output-stream (remote-id) 524 (or (and (use-dedicated-output-stream-p) 525 (open-dedicated-output-stream remote-id)) 526 (slynk-backend:make-output-stream 527 (make-thread-bindings-aware-lambda 528 (lambda (string) 529 (send-to-remote-channel remote-id `(:write-string ,string))))))) 530 531 (defun make-mrepl-input-stream (repl) 532 (slynk-backend:make-input-stream 533 (lambda () (read-input repl)))) 534 535 (defun open-dedicated-output-stream (remote-id) 536 "Establish a dedicated output connection to Emacs. 537 538 Emacs's channel at REMOTE-ID is notified of a socket listening at an 539 ephemeral port. Upon connection, the listening socket is closed, and 540 the resulting connecion socket is used as optimized way for Lisp to 541 deliver output to Emacs." 542 (let ((socket (slynk-backend:create-socket slynk::*loopback-interface* 543 *dedicated-output-stream-port*)) 544 (ef (or (some #'slynk::find-external-format '("utf-8-unix" "utf-8")) 545 (error "no suitable coding system for dedicated stream")))) 546 (unwind-protect 547 (let ((port (slynk-backend:local-port socket))) 548 (send-to-remote-channel remote-id 549 `(:open-dedicated-output-stream ,port nil)) 550 (let ((dedicated (slynk-backend:accept-connection 551 socket 552 :external-format ef 553 :buffering *dedicated-output-stream-buffering* 554 :timeout 30))) 555 (slynk:authenticate-client dedicated) 556 (slynk-backend:close-socket socket) 557 (setf socket nil) 558 (let ((result 559 ;; See github issue #21: Only sbcl and cmucl apparently 560 ;; respect :LINE as a buffering type, hence this reader 561 ;; conditional. This could/should be a definterface, but 562 ;; looks harmless enough... 563 ;; 564 #+(or sbcl cmucl) 565 dedicated 566 ;; ...on other implementations we make a relaying gray 567 ;; stream that is guaranteed to use line buffering for 568 ;; WRITE-SEQUENCE. That stream writes to the dedicated 569 ;; socket whenever it sees fit. 570 ;; 571 #-(or sbcl cmucl) 572 (slynk-backend:make-output-stream 573 (lambda (string) 574 (write-sequence string dedicated) 575 (force-output dedicated))))) 576 (prog1 result 577 (format result 578 "~&; Dedicated output stream setup (port ~a)~%" 579 port) 580 (force-output result))))) 581 (when socket 582 (slynk-backend:close-socket socket))))) 583 584 585 ;;;; Globally redirect IO to Emacs 586 ;;; 587 ;;; This code handles redirection of the standard I/O streams 588 ;;; (`*standard-output*', etc) into Emacs. If any LISTENER objects 589 ;;; exist in the CONNECTION structure, they will contain the 590 ;;; appropriate streams, so all we have to do is make the right 591 ;;; bindings. 592 ;;; 593 ;;; When the first ever MREPL is created we redirect the streams into 594 ;;; it, and they keep going into that MREPL even if more are 595 ;;; established, in the current connection or even other 596 ;;; connections. If the MREPL is closed (interactively or by closing 597 ;;; the connection), we choose some other MREPL (in some other default 598 ;;; connection possibly), or, or if there are no MREPL's left, we 599 ;;; revert to the original (real) streams. 600 ;;; 601 ;;; It is slightly tricky to assign the global values of standard 602 ;;; streams because they are often shadowed by dynamic bindings. We 603 ;;; solve this problem by introducing an extra indirection via synonym 604 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to 605 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" 606 ;;; variables, so they can always be assigned to affect a global 607 ;;; change. 608 (defvar *globally-redirect-io* :started-from-emacs 609 "If non-nil, attempt to globally redirect standard streams to Emacs. 610 If the value is :STARTED-FROM-EMACS, do it only if the Slynk server 611 was started from SLYNK:START-SERVER, which is called from Emacs by M-x 612 sly.") 613 614 (defvar *saved-global-streams* '() 615 "A plist to save and restore redirected stream objects. 616 E.g. the value for '*standard-output* holds the stream object 617 for *standard-output* before we install our redirection.") 618 619 (defvar *standard-output-streams* 620 '(*standard-output* *error-output* *trace-output*) 621 "The symbols naming standard output streams.") 622 623 (defvar *standard-input-streams* 624 '(*standard-input*) 625 "The symbols naming standard input streams.") 626 627 (defvar *standard-io-streams* 628 '(*debug-io* *query-io* *terminal-io*) 629 "The symbols naming standard io streams.") 630 631 (defvar *target-listener-for-redirection* nil 632 "The listener to which standard I/O streams are globally redirected. 633 NIL if streams are not globally redirected.") 634 635 (defun setup-stream-indirection (stream-var &optional stream) 636 "Setup redirection scaffolding for a global stream variable. 637 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: 638 639 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. 640 641 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as 642 *STANDARD-INPUT*. 643 644 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to 645 *CURRENT-STANDARD-INPUT*. 646 647 This has the effect of making *CURRENT-STANDARD-INPUT* contain the 648 effective global value for *STANDARD-INPUT*. This way we can assign 649 the effective global value even when *STANDARD-INPUT* is shadowed by a 650 dynamic binding." 651 (let ((current-stream-var (prefixed-var '#:current stream-var)) 652 (stream (or stream (symbol-value stream-var)))) 653 ;; Save the real stream value for the future. 654 (setf (getf *saved-global-streams* stream-var) stream) 655 ;; Define a new variable for the effective stream. 656 ;; This can be reassigned. 657 (proclaim `(special ,current-stream-var)) 658 (set current-stream-var stream) 659 ;; Assign the real binding as a synonym for the current one. 660 (let ((stream (make-synonym-stream current-stream-var))) 661 (set stream-var stream) 662 (slynk::set-default-initial-binding stream-var `(quote ,stream))))) 663 664 (defun prefixed-var (prefix variable-symbol) 665 "(PREFIXED-VAR \"FOO\" '*BAR*) => SLYNK::*FOO-BAR*" 666 (let ((basename (subseq (symbol-name variable-symbol) 1))) 667 (intern (format nil "*~A-~A" (string prefix) basename) :slynk))) 668 669 (defun init-global-stream-redirection () 670 (cond (*saved-global-streams* 671 (warn "Streams already redirected.")) 672 (t 673 (mapc #'setup-stream-indirection 674 (append *standard-output-streams* 675 *standard-input-streams* 676 *standard-io-streams*))))) 677 678 (defun globally-redirect-to-listener (listener) 679 "Set the standard I/O streams to redirect to LISTENER. 680 Assigns *CURRENT-<STREAM>* for all standard streams." 681 (saving-listener-bindings listener 682 (dolist (o *standard-output-streams*) 683 (set (prefixed-var '#:current o) 684 *standard-output*)) 685 686 ;; FIXME: If we redirect standard input to Emacs then we get the 687 ;; regular Lisp top-level trying to read from our REPL. 688 ;; 689 ;; Perhaps the ideal would be for the real top-level to run in a 690 ;; thread with local bindings for all the standard streams. Failing 691 ;; that we probably would like to inhibit it from reading while 692 ;; Emacs is connected. 693 ;; 694 ;; Meanwhile we just leave *standard-input* alone. 695 #+NIL 696 (dolist (i *standard-input-streams*) 697 (set (prefixed-var '#:current i) 698 (connection.user-input connection))) 699 (dolist (io *standard-io-streams*) 700 (set (prefixed-var '#:current io) 701 *terminal-io*)))) 702 703 (defun revert-global-io-redirection () 704 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams." 705 ;; Log to SLYNK:*LOG-OUTPUT* since the standard streams whose 706 ;; redirection are about to be reverted might be in an unconsistent 707 ;; state after, for instance, restarting an image. 708 ;; 709 (format slynk:*log-output* "~&; About to revert global IO direction~%") 710 (when *target-listener-for-redirection* 711 (flush-listener-streams *target-listener-for-redirection*)) 712 (dolist (stream-var (append *standard-output-streams* 713 *standard-input-streams* 714 *standard-io-streams*)) 715 (set (prefixed-var '#:current stream-var) 716 (getf *saved-global-streams* stream-var)))) 717 718 (defun globally-redirect-io-p () 719 (case *globally-redirect-io* 720 (:started-from-emacs slynk-api:*m-x-sly-from-emacs*) 721 (t *globally-redirect-io*))) 722 723 (defun maybe-redirect-global-io (connection) 724 "Consider globally redirecting output to CONNECTION's listener. 725 726 Return the current redirection target, or nil" 727 (let ((l (default-listener connection))) 728 (when (and (globally-redirect-io-p) 729 (null *target-listener-for-redirection*) 730 l) 731 (unless *saved-global-streams* 732 (init-global-stream-redirection)) 733 (setq *target-listener-for-redirection* l) 734 (globally-redirect-to-listener l) 735 (with-listener-bindings l 736 (format *standard-output* "~&; Redirecting all output to this MREPL~%") 737 (flush-listener-streams l))) 738 *target-listener-for-redirection*)) 739 740 (defmethod close-channel :before ((r mrepl) &key force) 741 (with-slots (mode remote-id) r 742 (unless (or force (eq mode :teardown)) 743 (send-to-remote-channel remote-id `(:server-side-repl-close))) 744 ;; If this channel was the redirection target. 745 (close-listener r) 746 (when (eq r *target-listener-for-redirection*) 747 (setq *target-listener-for-redirection* nil) 748 (maybe-redirect-global-io (default-connection)) 749 (unless *target-listener-for-redirection* 750 (revert-global-io-redirection) 751 (format slynk:*log-output* "~&; Reverted global IO direction~%"))))) 752 753 (provide :slynk/mrepl)