1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
|
;; Copyright (c) 2023 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later
#lang racket/base
(require racket/async-channel
racket/match
(only-in racket/port make-pipe-with-specials)
"image.rkt"
"repl-session.rkt")
(provide repl-output-channel
repl-output-error
repl-output-message
repl-output-run
repl-output-prompt
repl-output-exit
make-repl-output-manager
make-repl-output-port
make-repl-error-port
repl-error-port?
print-images-as-specials?)
;;; REPL output
;; Traditionally a REPL's output is a hopeless mix of things dumped
;; into stdout and stderr. This forces a client to use unreliable
;; regexps in an attempt to recover the original pieces.
;;
;; Instead we want structured output -- distinctly separated:
;; - current-output-port
;; - current-error-port
;; - printed values
;; - strings
;; - image files
;; - prompts
;; - structured errors from error-display-handler
;; - various messages from the back end
;; A channel from which the command-server can sync.
(define repl-output-channel (make-async-channel))
;; This manager thread mediates between the `repl-output' function and
;; the `repl-output-channel` async-channel. It seeks a warm bowl of
;; porridge for the number and size of stdout and stderr outputs.
;;
;; - stdout/stderr items may be held awhile in case the next item is
;; the same kind. A run of consecutive items within a time span are
;; consolidated into one.
;;
;; - On the other hand a very large stdout/stderr item is split into
;; multiple smaller ones.
;;
;; So this is a kind of buffering or "batching", but using a timer
;; instead of needing explicit flushing. At the same time, any
;; non-stdout/stderr kind of output will automatically "flush",
;; including items like 'prompt or 'run, so this works out fine as
;; well.
(struct repl-output-item (kind value))
(define ((repl-output-manager-thread session-id))
(define msec-threshold 20)
(define size-threshold 4096)
(define (put* kind value)
(async-channel-put repl-output-channel
(list 'repl-output session-id kind value)))
(define (put item)
(match item
[(repl-output-item (and kind (or (== 'stdout) (== 'stderr))) bstr)
(define len (bytes-length bstr))
(for ([beg (in-range 0 len size-threshold)])
(put* kind (subbytes bstr beg (min len (+ beg size-threshold)))))]
[(repl-output-item kind value)
(put* kind value)]))
(define pending-item #f)
(define pending-flush-alarm-evt never-evt)
(define (queue item)
(match-define (repl-output-item kind value) item)
(match pending-item
;; No pending item. When the new item is stdout or stderr, and
;; doesn't already exceed the size-threshold, set it as the
;; pending item and start our countdown.
[#f
#:when (and (memq kind '(stdout stderr))
(< (bytes-length value) size-threshold))
(set! pending-item item)
(set! pending-flush-alarm-evt
(alarm-evt (+ (current-inexact-milliseconds)
msec-threshold)))]
;; No pending item. Just send new item now.
[#f
(put item)]
;; There's a pending item. New item is same kind. When appending
;; their values is under the size-threshold, combine them.
[(repl-output-item (== kind) pending-value)
#:when (< (+ (bytes-length pending-value) (bytes-length value))
size-threshold)
(set! pending-item
(repl-output-item kind
(bytes-append pending-value value)))]
;; There's a pending item. Send it then the new item, now.
[(? repl-output-item?)
(flush-pending)
(put item)]))
(define (flush-pending)
(when pending-item
(put pending-item)
(set! pending-item #f))
(set! pending-flush-alarm-evt never-evt))
(let loop ()
(sync (handle-evt (thread-receive-evt)
(λ (_evt) (queue (thread-receive))))
(handle-evt pending-flush-alarm-evt
(λ (_evt) (flush-pending))))
(loop)))
(define (make-repl-output-manager session-id)
(thread (repl-output-manager-thread session-id)))
(define (repl-output kind value)
(define t (current-repl-output-manager))
(when t
(thread-send t
(repl-output-item kind value)
void)))
;; Various wrappers around repl-output:
;; To be called from the error-display-handler. Instead of raw text,
;; `v` may be any structured data that elisp-write can handle. As long
;; as the front end understands the structure, here we don't care.
(define (repl-output-error v)
(repl-output 'error v))
;; Replacement for the old `display-commented`: Miscellaneous messages
;; from this back end, as opposed to from Racket or from the user
;; program.
(define (repl-output-message v)
(repl-output 'message v))
;; To be called from get-interaction, i.e. "display-prompt".
(define (repl-output-prompt v)
(repl-output 'prompt v))
(define (repl-output-run v)
(repl-output 'run v))
(define (repl-output-exit)
(repl-output 'exit "REPL session ended"))
(define (repl-output-value v)
(repl-output 'value v))
(define (repl-output-value-special v)
(repl-output 'value-special v))
;;; Output port wrappers around repl-output:
(define (make-repl-port kind)
(define name (format "racket-mode-repl-~a" kind))
(define (write-out bstr start end non-block? breakable?)
(repl-output kind (subbytes bstr start end))
(- end start))
(define close void)
(make-output-port name
repl-output-channel
write-out
close))
;; Tuck the port in a struct just for a simple, reliable
;; repl-error-port? predicate.
(struct repl-error-port (p)
#:property prop:output-port 0)
(define (make-repl-error-port)
(repl-error-port (make-repl-port 'stderr)))
;; And do same for this, just for consistency.
(struct repl-output-port (p)
#:property prop:output-port 0)
(define (make-repl-output-port)
(define out (repl-output-port (make-repl-port 'stdout)))
(port-print-handler out (make-value-pipe-handler))
out)
;; A flag set by the port-print-handler for our repl-output-port.
;; Intended for use by our global-port-print-handler (see print.rkt).
;; When true, use racket/convert to write-special image values as
;; (cons 'image image-file-path-name) -- which obviously isn't
;; appropriate to do for ports generally.
(define print-images-as-specials? (make-parameter #f))
;; We want to avoid many calls to repl-output-value with short
;; strings. This can happen for example with pretty-print, which does
;; a print for each value within a list, plus for each space and
;; newline, etc.
;;
;; Use a pipe of unlimited size to accumulate all the printed bytes
;; and specials. Finally drain it using read-bytes-avail! to
;; consolidate runs of bytes (interrupted only by specials, if any) up
;; to a fixed buffer size.
;;
;; One wrinkle: bytes->string/utf-8 could fail if we happen to read
;; only some of a multi byte utf-8 sequence; issue #715. In that case,
;; read more bytes and try decoding again. If the buffer is full, grow
;; it just a little.
(define (make-value-pipe-handler)
;; Account for recursive calls to us, e.g. when the global port
;; print handler does pretty printing.
(define outermost? (make-parameter #t))
(define-values (pin pout) (make-value-pipe))
(define (racket-repl-output-port-handler v _out [depth 0])
(parameterize ([outermost? #f]
[print-images-as-specials? #t])
(match (convert-image v #:remove-from-cache? #t)
[(cons path-name _pixel-width)
(write-special (cons 'image path-name) pout)]
[#f
((global-port-print-handler) v pout depth)]))
(when (outermost?)
(drain-value-pipe pin pout)
(set!-values (pin pout) (make-value-pipe))))
racket-repl-output-port-handler)
(define (make-value-pipe)
(make-pipe-with-specials))
(define (drain-value-pipe in out)
(flush-output out)
(close-output-port out)
(let loop ([buffer (make-bytes 8192)]
[buffer-read-pos 0])
(match (read-bytes-avail! buffer in buffer-read-pos)
;; When read-bytes-avail! returns 0, it means there are bytes
;; available to read but no buffer space remaining. Grow buffer
;; by 8 bytes: 4 bytes max utf-8 sequence plus margin.
[0
(loop (bytes-append buffer (make-bytes 8))
(bytes-length buffer))]
[(? exact-nonnegative-integer? len)
(match (safe-bytes->string/utf-8 buffer len)
[#f
(loop buffer (+ buffer-read-pos len))]
[(? string? s)
(repl-output-value s)
(loop buffer 0)])]
[(? procedure? read-special)
;; m-p-w-specials ignores the position arguments so just pass
;; something satisfying the contract.
(define v (read-special #f #f #f 1))
(repl-output-value-special v)
(loop buffer 0)]
[(? eof-object?) (void)])))
(define (safe-bytes->string/utf-8 buffer len)
(with-handlers ([exn:fail:contract? (λ _ #f)])
(bytes->string/utf-8 buffer #f 0 len)))
|