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