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

.

Browse Source 
original commit: 909397bc79898efbdc4a8e27b545defbb1b12fff
This commit is contained in:
Robby Findler 2004-07-04 01:26:18 +00:00
parent 51c50c330c
commit 955daf6d1b
1 changed files with 147 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -846,18 +846,20 @@ WARNING: printf is rebound in the body of the unit to always
(define ports-mixin (define ports-mixin
(mixin ((class->interface text%) #;scheme:text<%>) (ports<%>) (mixin ((class->interface text%) #;scheme:text<%>) (ports<%>)
(inherit begin-edit-sequence (inherit begin-edit-sequence
end-edit-sequence
delete
insert
change-style change-style
split-snip delete
end-edit-sequence
find-snip find-snip
insert
get-start-position get-start-position
get-end-position get-end-position
get-snip-position get-snip-position
is-locked?
last-position last-position
lock lock
is-locked?) paragraph-start-position
position-paragraph
split-snip)
;; private field ;; private field
(define eventspace (current-eventspace)) (define eventspace (current-eventspace))
@ -904,7 +906,8 @@ WARNING: printf is rebound in the body of the unit to always
(define/public-final (set-allow-edits allow?) (set! allow-edits? allow?)) (define/public-final (set-allow-edits allow?) (set! allow-edits? allow?))
(define/public-final (get-allow-edits) allow-edits?) (define/public-final (get-allow-edits) allow-edits?)
(define/public-final (send-eof-to-in-port) (channel-put read-chan eof)) (define/public-final (send-eof-to-in-port)
(channel-put read-chan (cons eof (position->line-col-pos unread-start-point))))
(define/public-final (clear-input-port) (channel-put clear-input-chan (void))) (define/public-final (clear-input-port) (channel-put clear-input-chan (void)))
(define/public-final (clear-output-ports) (define/public-final (clear-output-ports)
(channel-put clear-output-chan (void)) (channel-put clear-output-chan (void))
@ -972,20 +975,21 @@ WARNING: printf is rebound in the body of the unit to always
(= start end) (= start end)
(submit-to-port? key)) (submit-to-port? key))
(insert "\n") (insert "\n")
(let ([snips/chars (extract-snips/chars unread-start-point (last-position))]) (for-each/snips-chars
(for-each (lambda (s/c) unread-start-point
(last-position)
(lambda (s/c line-col-pos)
(cond (cond
[(is-a? s/c snip%) [(is-a? s/c snip%)
(channel-put read-chan s/c)] (channel-put read-chan (cons s/c line-col-pos))]
[(char? s/c) [(char? s/c)
(for-each (lambda (b) (channel-put read-chan b)) (for-each (lambda (b) (channel-put read-chan (cons b line-col-pos)))
(bytes->list (string->bytes/utf-8 (string s/c))))])) (bytes->list (string->bytes/utf-8 (string s/c))))])))
snips/chars)
(set! allow-tabify? #f) (set! allow-tabify? #f)
(set! allow-tabify? #t) (set! allow-tabify? #t)
(set! unread-start-point (last-position)) (set! unread-start-point (last-position))
(set! insertion-point (last-position)) (set! insertion-point (last-position))
(on-submit))] (on-submit)]
[else [else
(super on-local-char key)]))) (super on-local-char key)])))
@ -1049,7 +1053,6 @@ WARNING: printf is rebound in the body of the unit to always
[old-insertion-point insertion-point]) [old-insertion-point insertion-point])
(set! insertion-point (+ insertion-point inserted-count)) (set! insertion-point (+ insertion-point inserted-count))
(set! unread-start-point (+ unread-start-point inserted-count)) (set! unread-start-point (+ unread-start-point inserted-count))
(printf "inc'd unread-start-position to ~s\n" unread-start-point)
(insert (if (is-a? str/snp snip%) (insert (if (is-a? str/snp snip%)
(send str/snp copy) (send str/snp copy)
@ -1070,8 +1073,8 @@ WARNING: printf is rebound in the body of the unit to always
(let loop (;; text-to-insert : (queue (cons (union snip bytes) style)) (let loop (;; text-to-insert : (queue (cons (union snip bytes) style))
[text-to-insert (empty-queue)] [text-to-insert (empty-queue)]
[last-flush (current-inexact-milliseconds)]) [last-flush (current-inexact-milliseconds)])
(sync
(sync
(if (queue-empty? text-to-insert) (if (queue-empty? text-to-insert)
never-evt never-evt
(handle-evt (handle-evt
@ -1080,7 +1083,6 @@ 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 always-evt) (queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds)))))) (loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt (handle-evt
flush-chan flush-chan
(lambda (return-evt) (lambda (return-evt)
@ -1184,7 +1186,9 @@ WARNING: printf is rebound in the body of the unit to always
;; input port sync code ;; input port sync code
;; ;;
;; read-chan : (channel (union byte snip eof)) ;; type line-col-pos = (list (union #f fixnum) (union #f fixnum) (union #f fixnum)))
;; read-chan : (channel (cons (union byte snip eof) line-col-pos))
;; send input from the editor ;; send input from the editor
(define read-chan (make-channel)) (define read-chan (make-channel))
@ -1200,6 +1204,9 @@ WARNING: printf is rebound in the body of the unit to always
;; clear-input-chan : (channel void) ;; clear-input-chan : (channel void)
(define clear-input-chan (make-channel)) (define clear-input-chan (make-channel))
;; position-chan : (channel (cons (channel void) (channel line-col-pos)))
(define position-chan (make-channel))
(define input-buffer-thread (define input-buffer-thread
(thread (thread
(lambda () (lambda ()
@ -1212,9 +1219,11 @@ WARNING: printf is rebound in the body of the unit to always
(define peeker-evt (semaphore-peek-evt peeker-sema)) (define peeker-evt (semaphore-peek-evt peeker-sema))
(define bytes-peeked 0) (define bytes-peeked 0)
(define response-evts '()) (define response-evts '())
(define peekers '()) (define peekers '()) ;; waiting for a peek
(define committers '()) (define committers '()) ;; waiting for a commit
(define data (empty-queue)) (define positioners '()) ;; waiting for a position
(define data (empty-queue)) ;; (queue (cons (union byte snip eof) line-col-pos))
(define position #f)
;; loop : -> alpha ;; loop : -> alpha
;; the main loop for this thread ;; the main loop for this thread
@ -1227,26 +1236,44 @@ WARNING: printf is rebound in the body of the unit to always
(service-committer data peeker-evt))]) (service-committer data peeker-evt))])
(set! peekers not-ready-peekers) (set! peekers not-ready-peekers)
(set! committers potential-commits) (set! committers potential-commits)
(set! response-evts (append response-evts (set! response-evts
(append response-evts
new-peek-response-evts new-peek-response-evts
new-commit-response-evts)) new-commit-response-evts))
(sync (sync
(handle-evt
position-chan
(lambda (pr)
;(printf "position-chan\n")
(let ([nack-chan (car pr)]
[resp-chan (cdr pr)])
(set! positioners (cons pr positioners))
(loop))))
(if position
(apply choice-evt (map service-positioner positioners))
never-evt)
(handle-evt (handle-evt
read-chan read-chan
(lambda (ent) (lambda (ent)
;(printf "read-chan\n")
(set! data (enqueue ent data)) (set! data (enqueue ent data))
(unless position
(set! position (cdr ent)))
(loop))) (loop)))
(handle-evt (handle-evt
clear-input-chan clear-input-chan
(lambda (_) (lambda (_)
;(printf "clear-input-chan\n")
(semaphore-post peeker-sema) (semaphore-post peeker-sema)
(set! peeker-sema (make-semaphore 0)) (set! peeker-sema (make-semaphore 0))
(set! peeker-evt (semaphore-peek-evt peeker-sema)) (set! peeker-evt (semaphore-peek-evt peeker-sema))
(set! data (empty-queue)) (set! data (empty-queue))
(set! position #f)
(loop))) (loop)))
(handle-evt (handle-evt
progress-event-chan progress-event-chan
(lambda (return-pr) (lambda (return-pr)
;(printf "progress-event-chan\n")
(let ([return-chan (car return-pr)] (let ([return-chan (car return-pr)]
[return-nack (cdr return-pr)]) [return-nack (cdr return-pr)])
(set! response-evts (set! response-evts
@ -1258,12 +1285,13 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
peek-chan peek-chan
(lambda (peeker) (lambda (peeker)
(print-struct #t) ;(printf "peek-chan\n")
(set! peekers (cons peeker peekers)) (set! peekers (cons peeker peekers))
(loop))) (loop)))
(handle-evt (handle-evt
commit-chan commit-chan
(lambda (committer) (lambda (committer)
;(printf "commit-chan\n")
(set! committers (cons committer committers)) (set! committers (cons committer committers))
(loop))) (loop)))
(apply (apply
@ -1281,11 +1309,18 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
commit-peeker-evt commit-peeker-evt
(lambda (_) (lambda (_)
;(printf "commit-peeker-evt\n")
;; this committer will be thrown out in next iteration ;; this committer will be thrown out in next iteration
(loop))) (loop)))
(handle-evt (handle-evt
done-evt done-evt
(lambda (v) (lambda (v)
;(printf "done-evt\n")
(let ([nth-pos (cdr (peek-n data (- kr 1)))])
(set! position
(list (car nth-pos)
(+ 1 (cadr nth-pos))
(+ 1 (caddr nth-pos)))))
(set! data (dequeue-n data kr)) (set! data (dequeue-n data kr))
(semaphore-post peeker-sema) (semaphore-post peeker-sema)
(set! peeker-sema (make-semaphore 0)) (set! peeker-sema (make-semaphore 0))
@ -1304,28 +1339,23 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
resp-evt resp-evt
(lambda (_) (lambda (_)
;(printf "resp-evt\n")
(set! response-evts (remq resp-evt response-evts)) (set! response-evts (remq resp-evt response-evts))
(loop)))) (loop))))
response-evts))))) response-evts)))))
;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y)) ;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt
;; separates `eles' into two lists -- those that `f' returns #f for (define (service-positioner pr)
;; and then the results of calling `f' for those where `f' doesn't return #f ;(printf "service-position ~s\n" pr)
(define (separate eles f) (let ([nack-evt (car pr)]
(let loop ([eles eles] [resp-evt (cdr pr)])
[transformed '()] (handle-evt
[left-alone '()]) (choice-evt nack-evt
(cond (channel-put-evt resp-evt position))
[(null? eles) (values left-alone transformed)] (let ([sent-position position])
[else (let* ([ele (car eles)] (lambda (_)
[maybe (f ele)]) (set! positioners (remq pr positioners))
(if maybe (loop))))))
(loop (cdr eles)
(cons maybe transformed)
left-alone)
(loop (cdr eles)
transformed
(cons ele left-alone))))])))
;; service-committer : queue evt -> committer -> (union #f evt) ;; service-committer : queue evt -> committer -> (union #f evt)
;; if the committer can be dumped, return an evt that ;; if the committer can be dumped, return an evt that
@ -1359,7 +1389,7 @@ WARNING: printf is rebound in the body of the unit to always
(choice-evt (channel-put-evt resp-chan #f) (choice-evt (channel-put-evt resp-chan #f)
nack-evt)] nack-evt)]
[((queue-size data) . > . skip-count) [((queue-size data) . > . skip-count)
(let ([nth (peek-n data skip-count)]) (let ([nth (car (peek-n data skip-count))])
(choice-evt (choice-evt
nack-evt nack-evt
(cond (cond
@ -1376,6 +1406,26 @@ WARNING: printf is rebound in the body of the unit to always
[else [else
#f])])) #f])]))
;; separate (listof X) (X -> (union #f Y)) -> (values (listof X) (listof Y))
;; separates `eles' into two lists -- those that `f' returns #f for
;; and then the results of calling `f' for those where `f' doesn't return #f
(define (separate eles f)
(let loop ([eles eles]
[transformed '()]
[left-alone '()])
(cond
[(null? eles) (values left-alone transformed)]
[else (let* ([ele (car eles)]
[maybe (f ele)])
(if maybe
(loop (cdr eles)
(cons maybe transformed)
left-alone)
(loop (cdr eles)
transformed
(cons ele left-alone))))])))
;;; start things going
(loop)))) (loop))))
(define/private (init-input-port) (define/private (init-input-port)
@ -1426,33 +1476,63 @@ WARNING: printf is rebound in the body of the unit to always
(define (close-proc) (void)) (define (close-proc) (void))
(define (position-proc)
(let ([chan (make-channel)])
(apply
values
(sync
(nack-guard-evt
(lambda (fail)
(channel-put position-chan (cons fail chan))
chan))))))
(set! in-port (make-input-port this (set! in-port (make-input-port this
read-bytes-proc read-bytes-proc
peek-proc peek-proc
close-proc close-proc
progress-evt-proc progress-evt-proc
commit-proc))) commit-proc
position-proc))
(port-count-lines! in-port))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; helpers ;; helpers
;; ;;
;; extract-snips/chars : number number -> (listof (union char snip))
(define/private (extract-snips/chars start end) ;; position->line-col-pos : number -> (list number number number)
(define/private (position->line-col-pos pos)
(let* ([para (position-paragraph pos)]
[para-start (paragraph-start-position para)])
(list para
(- pos para-start)
pos)))
;; for-each/snips-chars : number number ((union char snip) line-col-pos -> void) -> void
(define/private (for-each/snips-chars start end func)
(split-snip start) (split-snip start)
(split-snip end) (split-snip end)
(let loop ([snip (find-snip start 'after-or-none)]) (let loop ([snip (find-snip start 'after-or-none)])
(cond (cond
[(not snip) null] [(not snip) (void)]
[(< (get-snip-position snip) end) [(< (get-snip-position snip) end)
(if (is-a? snip string-snip%) (let ([line-col-pos (position->line-col-pos (get-snip-position snip))])
(append (string->list (send snip get-text 0 (send snip get-count))) (cond
(loop (send snip next))) [(is-a? snip string-snip%)
(cons (send snip copy) (let ([str (send snip get-text 0 (send snip get-count))])
(loop (send snip next))))] (let loop ([i 0])
[else null]))) (when (< i (string-length str))
(func (string-ref str i)
(list (car line-col-pos)
(+ i (cadr line-col-pos))
(+ i (caddr line-col-pos))))
(loop (+ i 1)))))
(loop (send snip next))]
[else
(func (send snip copy) line-col-pos)
(loop (send snip next))]))]
[else (void)])))
;; dequeue-n : queue number -> queue ;; dequeue-n : queue number -> queue
(define (dequeue-n queue n) (define (dequeue-n queue n)
@ -1486,10 +1566,11 @@ WARNING: printf is rebound in the body of the unit to always
;; 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 ([lst (queue->list q)]) (let ([lst (queue->list q)])
(if (null? lst)
(values null (empty-queue))
(let loop ([lst lst] (let loop ([lst lst]
[acc null]) [acc null])
(if (null? lst)
(values (reverse acc)
(empty-queue))
(let-values ([(front rest) (peel lst)]) (let-values ([(front rest) (peel lst)])
(cond (cond
[(not front) (values (reverse acc) [(not front) (values (reverse acc)
@ -1520,7 +1601,7 @@ WARNING: printf is rebound in the body of the unit to always
[else (loop rest [else (loop rest
(cons front acc))])))))) (cons front acc))]))))))
;; peel : (listof (cons (union snip bytes) X) ;; peel : (cons (cons (union snip bytes) X) (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)
;; finds the first segment of bytes with the same style and combines them, ;; finds the first segment of bytes with the same style and combines them,
;; otherwise a lot like (define (peel x) (values (car x) (cdr x))) ;; otherwise a lot like (define (peel x) (values (car x) (cdr x)))