suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lift the restriction that the text:ports mixin

Browse Source 
cannot do io from the eventspace handler thread
and add a test suite for text:ports
This commit is contained in:
Robby Findler 2011-02-15 09:00:22 -06:00 committed by Robby Findler
parent 62c961410c
commit 8e94ce49e4
3 changed files with 196 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/framework/private/text.rkt
View File

@ -1825,6 +1825,9 @@
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500)
;; this value (4096) is also mentioned in the test suite (collects/tests/framework/test.rkt)
;; so if you change it, be sure to change things over there too
(define output-buffer-full 4096)
(define-local-member-name
@ -1873,6 +1876,17 @@
(send value-sd set-delta-foreground (make-object color% 0 0 175))
(create-style-name value-style-name value-sd)))
;; data : any
;; to-insert-chan : (or/c #f channel)
;; if to-insert-chan is a channel, this means
;; the eventspace handler thread is the one that
;; is initiating the communication, so instead of
;; queueing a callback to do the update of the editor,
;; just send the work back directly and it will be done
;; syncronously there. If it is #f, then we queue a callback
;; to do the work
(define-struct data/chan (data to-insert-chan))
(define ports-mixin
(mixin (wide-snip<%>) (ports<%>)
(inherit begin-edit-sequence
@ -2257,13 +2271,16 @@
(alarm-evt (+ last-flush msec-timeout))
(λ (_)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
;; we always queue the work here since the always event means no one waits for the callback
(queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt
flush-chan
(λ (return-evt)
(λ (return-evt/to-insert-chan)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes return-evt)
(if (channel? return-evt/to-insert-chan)
(channel-put return-evt/to-insert-chan viable-bytes)
(queue-insertion viable-bytes return-evt/to-insert-chan))
(loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt
clear-output-chan
@ -2271,16 +2288,22 @@
(loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt
write-chan
(λ (pr)
(λ (pr-pr)
(define return-chan (car pr-pr))
(define pr (cdr pr-pr))
(let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond
[((queue-size text-to-insert) . < . output-buffer-full)
(when return-chan
(channel-put return-chan '()))
(loop new-text-to-insert last-flush)]
[else
(let ([chan (make-channel)])
(let-values ([(viable-bytes remaining-queue)
(split-queue converter new-text-to-insert)])
(queue-insertion viable-bytes (channel-put-evt chan (void)))
(if return-chan
(channel-put return-chan viable-bytes)
(queue-insertion viable-bytes (channel-put-evt chan (void))))
(channel-get chan)
(loop remaining-queue (current-inexact-milliseconds))))]))))))))))
@ -2300,16 +2323,23 @@
(λ (to-write start end block/buffer? enable-breaks?)
(cond
[(= start end) (flush-proc)]
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
[else
(channel-put write-chan (cons (subbytes to-write start end) style))])
(define pair (cons (subbytes to-write start end) style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-channel (make-channel))
(thread (λ () (channel-put write-chan (cons return-channel pair))))
(do-insertion (channel-get return-channel) #f)]
[else
(channel-put write-chan (cons #f pair))])])
(- end start)))
(define (flush-proc)
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'flush-proc "cannot flush port on eventspace main thread")]
(define to-insert-channel (make-channel))
(thread (λ () (channel-put flush-chan to-insert-channel)))
(do-insertion (channel-get to-insert-channel) #f)]
[else
(sync
(nack-guard-evt
@ -2327,17 +2357,18 @@
(define (make-write-special-proc style)
(λ (special can-buffer? enable-breaks?)
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
[else
(let ([str/snp (cond
(define str/snp (cond
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)])])
(channel-put
write-chan
(cons str/snp style)))])
[else (format "~s" special)]))
(define to-send (cons str/snp style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-chan (make-channel))
(thread (λ () (channel-put write-chan (cons return-chan to-send))))
(do-insertion (channel-get return-chan) #f)]
[else
(channel-put write-chan (cons #f to-send))])
#t))
(let* ([add-standard

7
collects/scribblings/framework/text.scrbl
View File

@ -818,7 +818,7 @@
}
@definterface[text:ports<%> ()]{
Classes implementing this interface (via the associated
mixin) support input and output ports that read from the
mixin) support input and output ports that read from and to the
editor.
There are two input ports: the normal input port just reads
@ -826,6 +826,11 @@
inserts an editor snip into this text and uses input typed
into the box as input into the port.
There are three output ports, designed to match stdout, stderr,
and a special port for printing values. The only difference
between them is the output is rendered in different colors
when it comes in via the different ports.
They create three threads to mediate access to the input and
output ports (one for each input port and one for all of the
output ports).

142
collects/tests/framework/text.rkt
View File

@ -196,3 +196,145 @@
(send dc clear)
(send t print-to-dc dc 1)
'no-error))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; text:ports
;;
;; there is an internal buffer of this size, so writes that are larger and smaller are interesting
(define buffer-size 4096)
(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))]
[non-ascii-str "λαβ一二三四五"])
(define (do/separate-thread str mtd)
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t ,mtd)]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(display ,str op)
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position)))))
(test
'text:ports%.1
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-out-port)))
(test
'text:ports%.2
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-out-port)))
(test
'text:ports%.3
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-out-port)))
(test
'text:ports%.4
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-err-port)))
(test
'text:ports%.5
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-err-port)))
(test
'text:ports%.6
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-err-port)))
(test
'text:ports%.7
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-value-port)))
(test
'text:ports%.8
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-value-port)))
(test
'text:ports%.9
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-value-port)))
;; display the big string, one char at a time
(test
'text:ports%.10
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[big-str ,big-str]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(let loop ([i 0])
(when (< i (string-length big-str))
(display (string-ref big-str i) op)
(loop (+ i 1))))
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position))))))
;; the next tests test the interaction when the current
;; thread is the same as the handler thread of the eventspace
;; where the text was created
(test
'text:ports%.thd1
(λ (x) (equal? x "abc"))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[exn #f])
(display "abc" op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd2
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,big-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd3
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd4
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position)))))))