lift the restriction that the text:ports mixin

cannot do io from the eventspace handler thread
and add a test suite for text:ports

collects/framework/private/text.rkt

@@ -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
+          (define str/snp (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
                             [(string? special) special]
                             [(is-a? special snip%) special]
-                              [else (format "~s" special)])])
+                            [else (format "~s" special)]))
-               (channel-put 
+          (define to-send (cons str/snp style))
-                write-chan 
+          (cond
-                (cons str/snp style)))])
+            [(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

collects/scribblings/framework/text.scrbl

@@ -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).

collects/tests/framework/text.rkt

@@ -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)))))))