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

.

Browse Source 
original commit: 3255a9878236874666be1e8575c2cea8e45faf41
This commit is contained in:
Robby Findler 2004-04-08 19:47:48 +00:00
parent 78e9bcf6be
commit 76335726c8
1 changed files with 70 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
collects/framework/private/text.ss
View File

@ -845,6 +845,7 @@ WARNING: printf is rebound in the body of the unit to always
submit-to-port? submit-to-port?
on-submit on-submit
send-eof-to-in-port send-eof-to-in-port
flush-output-ports
get-in-port get-in-port
get-out-port get-out-port
get-err-port get-err-port
@ -904,6 +905,26 @@ WARNING: printf is rebound in the body of the unit to always
(define/public (send-eof-to-in-port) (channel-put read-chan eof)) (define/public (send-eof-to-in-port) (channel-put read-chan eof))
(define/public (flush-output-ports)
(let ([c (make-channel)])
(channel-put this-eventspace-flush-chan c)
(let ([viable-bytes (channel-get c)])
(do-insertion viable-bytes))))
(define/public (get-in-port)
(unless in-port (error 'get-in-port "not ready"))
in-port)
(define/public (get-out-port)
(unless out-port (error 'get-out-port "not ready"))
out-port)
(define/public (get-err-port)
(unless err-port (error 'get-err-port "not ready"))
err-port)
(define/public (get-value-port)
(unless err-port (error 'get-value-port "not ready"))
value-port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; specialization interface ;; specialization interface
@ -941,6 +962,7 @@ WARNING: printf is rebound in the body of the unit to always
(= start end) (= start end)
(submit-to-port? key)) (submit-to-port? key))
(let ([snips/chars (extract-snips/chars unread-start-point (last-position))]) (let ([snips/chars (extract-snips/chars unread-start-point (last-position))])
(printf "sending over ~s ~s\n" unread-start-point snips/chars)
(for-each (lambda (s/c) (for-each (lambda (s/c)
(cond (cond
[(is-a? s/c snip%) [(is-a? s/c snip%)
@ -976,6 +998,11 @@ WARNING: printf is rebound in the body of the unit to always
;; the waitable inside is waited on to indicate the flush has occurred ;; the waitable inside is waited on to indicate the flush has occurred
(define flush-chan (make-channel)) (define flush-chan (make-channel))
;; this-eventspace-flush-chan : (channel (channel viable-bytes))
;; used to do syncs on the main eventspace
(define this-eventspace-flush-chan (make-channel))
;; write-chan : (channel (cons bytes style)) ;; write-chan : (channel (cons bytes style))
;; send output to the editor ;; send output to the editor
(define write-chan (make-channel)) (define write-chan (make-channel))
@ -1002,6 +1029,7 @@ WARNING: printf is rebound in the body of the unit to always
;; do-insertion : (listof (cons (union string snip) style-delta)) -> void ;; do-insertion : (listof (cons (union string snip) style-delta)) -> void
;; thread: eventspace main thread ;; thread: eventspace main thread
(define/private (do-insertion txts) (define/private (do-insertion txts)
(printf "do-insertion.1 ~s\n" txts)
(let ([locked? (is-locked?)]) (let ([locked? (is-locked?)])
(begin-edit-sequence) (begin-edit-sequence)
(lock #f) (lock #f)
@ -1027,6 +1055,7 @@ WARNING: printf is rebound in the body of the unit to always
(set! unread-start-point (+ unread-start-point inserted-count)))) (set! unread-start-point (+ unread-start-point inserted-count))))
(loop (cdr txts))])) (loop (cdr txts))]))
(lock locked?) (lock locked?)
(printf "do-insertion.2 ip ~s usp ~s\n" insertion-point unread-start-point)
(end-edit-sequence))) (end-edit-sequence)))
(define input-buffer-thread (define input-buffer-thread
@ -1093,6 +1122,12 @@ WARNING: printf is rebound in the body of the unit to always
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes return-waitable) (queue-insertion viable-bytes return-waitable)
(loop remaining-queue)))) (loop remaining-queue))))
(make-wrapped-waitable
this-eventspace-flush-chan
(lambda (return)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(channel-put return viable-bytes)
(loop remaining-queue))))
(make-wrapped-waitable (make-wrapped-waitable
write-chan write-chan
(lambda (pr) (lambda (pr)
@ -1110,19 +1145,6 @@ WARNING: printf is rebound in the body of the unit to always
[out-port #f] [out-port #f]
[err-port #f] [err-port #f]
[value-port #f]) [value-port #f])
(define/public (get-in-port)
(unless in-port (error 'get-in-port "not ready"))
in-port)
(define/public (get-out-port)
(unless out-port (error 'get-out-port "not ready"))
out-port)
(define/public (get-err-port)
(unless err-port (error 'get-err-port "not ready"))
err-port)
(define/public (get-value-port)
(unless err-port (error 'get-value-port "not ready"))
value-port)
(let () (let ()
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1152,10 +1174,7 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (src line column position) (lambda (src line column position)
(values s/c 1))]))) (values s/c 1))])))
(define (in-close-proc) (define (in-close-proc) (void))
(printf "closed port\n")
(car)
(void))
(define (make-write-bytes-proc style) (define (make-write-bytes-proc style)
(lambda (to-write start end block/buffer?) (lambda (to-write start end block/buffer?)
@ -1236,37 +1255,40 @@ WARNING: printf is rebound in the body of the unit to always
;; extracts the viable bytes (and other stuff) from the front of the queue ;; extracts the viable bytes (and other stuff) from the front of the queue
;; and returns them as strings (and other stuff). ;; and returns them as strings (and other stuff).
(define/private (split-queue converter q) (define/private (split-queue converter q)
(let loop ([lst (queue->list q)] (let ([lst (queue->list q)])
[acc null]) (if (null? lst)
(let-values ([(front rest) (peel lst)]) (values null (empty-queue))
(cond (let loop ([lst lst]
[(not front) (values (reverse acc) [acc null])
(empty-queue))] (let-values ([(front rest) (peel lst)])
[(bytes? (car front)) (cond
(let ([the-bytes (car front)] [(not front) (values (reverse acc)
[key (cdr front)]) (empty-queue))]
(if (null? rest) [(bytes? (car front))
(let-values ([(converted-bytes src-read-k termination) (let ([the-bytes (car front)]
(bytes-convert converter the-bytes)]) [key (cdr front)])
(if (eq? termination 'aborts) (if (null? rest)
(values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) (let-values ([(converted-bytes src-read-k termination)
(enqueue (bytes-convert converter the-bytes)])
(cons (subbytes the-bytes (if (eq? termination 'aborts)
(- (bytes-length the-bytes) src-read-k) (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
(bytes-length the-bytes)) (enqueue
key) (cons (subbytes the-bytes
(empty-queue))) (- (bytes-length the-bytes) src-read-k)
(values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc)) (bytes-length the-bytes))
(empty-queue)))) key)
(let-values ([(converted-bytes src-read-k termination) (empty-queue)))
(bytes-convert converter the-bytes)] (values (reverse (cons (cons (bytes->string/utf-8 converted-bytes) key) acc))
[(more-bytes more-termination) (bytes-convert-end converter)]) (empty-queue))))
(loop rest (let-values ([(converted-bytes src-read-k termination)
(cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes)) (bytes-convert converter the-bytes)]
key) [(more-bytes more-termination) (bytes-convert-end converter)])
acc)))))] (loop rest
[else (loop rest (cons (cons (bytes->string/utf-8 (bytes-append converted-bytes more-bytes))
(cons front acc))])))) key)
acc)))))]
[else (loop rest
(cons front acc))]))))))
;; peel : (listof (cons (union snip bytes) X) ;; peel : (listof (cons (union snip bytes) X)
;; -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X) ;; -> (values (cons (union snip bytes) X) (listof (cons (union snip bytes) X)