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

.

Browse Source 
original commit: c4a9010d1705aa5d24e0e7f7958e8aac09f0a165
This commit is contained in:
Robby Findler 2004-06-30 18:51:43 +00:00
parent e72c8fb672
commit ff3b3f0d3f
3 changed files with 63 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/framework/private/color.ss
View File

@ -78,6 +78,7 @@
;; If the tree is completed ;; If the tree is completed
(define up-to-date? #t) (define up-to-date? #t)
(define/public (get-up-to-date?) up-to-date?)
;; The tree of tokens that have been invalidated by an edit ;; The tree of tokens that have been invalidated by an edit
;; but might still be valid. ;; but might still be valid.
@ -109,6 +110,8 @@
(set! start-pos start) (set! start-pos start)
(set! end-pos end) (set! end-pos end)
(reset-tokens)) (reset-tokens))
(define/public (get-region) (values start-pos end-pos))
;; Modify the end of the region. ;; Modify the end of the region.
(define/public (update-region-end end) (define/public (update-region-end end)
@ -394,8 +397,7 @@
;; ----------------------- Match parentheses ---------------------------- ;; ----------------------- Match parentheses ----------------------------
(define clear-old-locations 'dummy) (define clear-old-locations void)
(set! clear-old-locations void)
(define mismatch-color (make-object color% "PINK")) (define mismatch-color (make-object color% "PINK"))
(define/private (get-match-color) (preferences:get 'framework:paren-match-color)) (define/private (get-match-color) (preferences:get 'framework:paren-match-color))
@ -704,9 +706,6 @@
(super on-enable-surrogate text) (super on-enable-surrogate text)
(send text start-colorer token-sym->style get-token matches)) (send text start-colorer token-sym->style get-token matches))
(super-instantiate ()))) (super-new)))
(define text-mode% (text-mode-mixin mode:surrogate-text%)))) (define text-mode% (text-mode-mixin mode:surrogate-text%)))))
)

3
collects/framework/private/scheme.ss
View File

@ -592,14 +592,11 @@
(define (tabify-all) (tabify-selection 0 (last-position))) (define (tabify-all) (tabify-selection 0 (last-position)))
(define (insert-return) (define (insert-return)
(printf "insert-return ~s\n" (tabify-on-return?))
(if (tabify-on-return?) (if (tabify-on-return?)
(begin (begin
(begin-edit-sequence) (begin-edit-sequence)
(insert #\newline) (insert #\newline)
(printf "calling tabify\n")
(tabify (get-start-position)) (tabify (get-start-position))
(printf "called tabify\n")
(set-position (set-position
(let loop ([new-pos (get-start-position)]) (let loop ([new-pos (get-start-position)])
(if (let ([next (get-character new-pos)]) (if (let ([next (get-character new-pos)])

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

@ -839,6 +839,9 @@ WARNING: printf is rebound in the body of the unit to always
(define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector)) (define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector))
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500)
(define output-buffer-full 4096)
(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
@ -954,6 +957,7 @@ WARNING: printf is rebound in the body of the unit to always
[(and (insertion-point . <= . start) [(and (insertion-point . <= . start)
(= start end) (= start end)
(submit-to-port? key)) (submit-to-port? key))
(insert "\n")
(let ([snips/chars (extract-snips/chars unread-start-point (last-position))]) (let ([snips/chars (extract-snips/chars unread-start-point (last-position))])
(for-each (lambda (s/c) (for-each (lambda (s/c)
(cond (cond
@ -963,9 +967,7 @@ WARNING: printf is rebound in the body of the unit to always
(for-each (lambda (b) (channel-put read-chan b)) (for-each (lambda (b) (channel-put read-chan b))
(bytes->list (string->bytes/utf-8 (string s/c))))])) (bytes->list (string->bytes/utf-8 (string s/c))))]))
snips/chars) snips/chars)
(channel-put read-chan (bytes-ref #"\n" 0))
(set! allow-tabify? #f) (set! allow-tabify? #f)
(super on-local-char key)
(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))
@ -1042,35 +1044,47 @@ WARNING: printf is rebound in the body of the unit to always
(end-edit-sequence))) (end-edit-sequence)))
(define output-buffer-thread (define output-buffer-thread
(let ([buffer-full 40] (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
[converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(thread (thread
(lambda () (lambda ()
(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)])
(sync (sync
(if (queue-empty? text-to-insert)
never-evt
(handle-evt
(alarm-evt (+ last-flush msec-timeout))
(lambda (_)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt (handle-evt
flush-chan flush-chan
(lambda (return-evt) (lambda (return-evt)
(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-evt) (queue-insertion viable-bytes return-evt)
(loop remaining-queue)))) (loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt (handle-evt
clear-output-chan clear-output-chan
(lambda (_) (lambda (_)
(loop (empty-queue)))) (loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt (handle-evt
write-chan write-chan
(lambda (pr) (lambda (pr)
(cond (let ([new-text-to-insert (enqueue pr text-to-insert)])
[((queue-size text-to-insert) . < . buffer-full) (cond
(loop (enqueue pr text-to-insert))] [((queue-size text-to-insert) . < . output-buffer-full)
[else (loop new-text-to-insert last-flush)]
(let ([chan (make-channel)]) [else
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let ([chan (make-channel)])
(queue-insertion viable-bytes (channel-put-evt chan (void))) (let-values ([(viable-bytes remaining-queue)
(channel-get chan) (split-queue converter new-text-to-insert)])
(loop remaining-queue)))]))))))))) (queue-insertion viable-bytes (channel-put-evt chan (void)))
(channel-get chan)
(loop remaining-queue (current-inexact-milliseconds))))]))))))))))
(field [in-port #f] (field [in-port #f]
[out-port #f] [out-port #f]
@ -1124,7 +1138,7 @@ WARNING: printf is rebound in the body of the unit to always
(define out-sd (make-object style-delta% 'change-normal)) (define out-sd (make-object style-delta% 'change-normal))
(define err-sd (make-object style-delta% 'change-italic)) (define err-sd (make-object style-delta% 'change-italic))
(define value-sd (make-object style-delta% 'change-normal)) (define value-sd (make-object style-delta% 'change-family 'modern))
(send out-sd set-delta-foreground (make-object color% 150 0 150)) (send out-sd set-delta-foreground (make-object color% 150 0 150))
(send err-sd set-delta-foreground (make-object color% 255 0 0)) (send err-sd set-delta-foreground (make-object color% 255 0 0))
(send value-sd set-delta-foreground (make-object color% 0 0 175)) (send value-sd set-delta-foreground (make-object color% 0 0 175))
@ -1622,27 +1636,41 @@ WARNING: printf is rebound in the body of the unit to always
;; ;;
;; queues ;; queues
;; ;;
(define-struct queue (eles count)) (define-struct queue (front back count))
(define (empty-queue) (make-queue '() 0)) (define (empty-queue) (make-queue '() '() 0))
(define (enqueue e q) (make-queue (append (queue-eles q) (list e)) (define (enqueue e q) (make-queue
(+ (queue-count q) 1))) (cons e (queue-front q))
(queue-back q)
(+ (queue-count q) 1)))
(define (queue-first q) (define (queue-first q)
(let ([eles (queue-eles q)]) (flip-around q)
(if (null? eles) (let ([back (queue-back q)])
(if (null? back)
(error 'queue-first "empty queue") (error 'queue-first "empty queue")
(car eles)))) (car back))))
(define (queue-rest q) (define (queue-rest q)
(let ([eles (queue-eles q)]) (flip-around q)
(if (null? eles) (let ([back (queue-back q)])
(if (null? back)
(error 'queue-rest "empty queue") (error 'queue-rest "empty queue")
(make-queue (cdr eles) (make-queue (queue-front q)
(cdr back)
(- (queue-count q) 1))))) (- (queue-count q) 1)))))
(define (queue-empty? q) (null? (queue-eles q))) (define (flip-around q)
(when (null? (queue-back q))
(set-queue-back! q (reverse (queue-front q)))
(set-queue-front! q '())))
(define (queue-empty? q) (zero? (queue-count q)))
(define (queue-size q) (queue-count q)) (define (queue-size q) (queue-count q))
;; queue->list : (queue x) -> (listof x) ;; queue->list : (queue x) -> (listof x)
;; returns the elements in the order that successive deq's would have ;; returns the elements in the order that successive deq's would have
(define (queue->list q) (queue-eles q)) (define (queue->list q)
(let ([ans (append (queue-back q) (reverse (queue-front q)))])
(set-queue-back! q ans)
(set-queue-front! q '())
ans))
;; ;;
;; end queue abstraction ;; end queue abstraction