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
(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
;; but might still be valid.
@ -110,6 +111,8 @@
(set! end-pos end)
(reset-tokens))
(define/public (get-region) (values start-pos end-pos))
;; Modify the end of the region.
(define/public (update-region-end end)
(set! end-pos end))
@ -394,8 +397,7 @@
;; ----------------------- Match parentheses ----------------------------
(define clear-old-locations 'dummy)
(set! clear-old-locations void)
(define clear-old-locations void)
(define mismatch-color (make-object color% "PINK"))
(define/private (get-match-color) (preferences:get 'framework:paren-match-color))
@ -704,9 +706,6 @@
(super on-enable-surrogate text)
(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 (insert-return)
(printf "insert-return ~s\n" (tabify-on-return?))
(if (tabify-on-return?)
(begin
(begin-edit-sequence)
(insert #\newline)
(printf "calling tabify\n")
(tabify (get-start-position))
(printf "called tabify\n")
(set-position
(let loop ([new-pos (get-start-position)])
(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 committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500)
(define output-buffer-full 4096)
(define ports-mixin
(mixin ((class->interface text%) #;scheme:text<%>) (ports<%>)
(inherit begin-edit-sequence
@ -954,6 +957,7 @@ WARNING: printf is rebound in the body of the unit to always
[(and (insertion-point . <= . start)
(= start end)
(submit-to-port? key))
(insert "\n")
(let ([snips/chars (extract-snips/chars unread-start-point (last-position))])
(for-each (lambda (s/c)
(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))
(bytes->list (string->bytes/utf-8 (string s/c))))]))
snips/chars)
(channel-put read-chan (bytes-ref #"\n" 0))
(set! allow-tabify? #f)
(super on-local-char key)
(set! allow-tabify? #t)
(set! unread-start-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)))
(define output-buffer-thread
(let ([buffer-full 40]
[converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(thread
(lambda ()
(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
(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
flush-chan
(lambda (return-evt)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes return-evt)
(loop remaining-queue))))
(loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt
clear-output-chan
(lambda (_)
(loop (empty-queue))))
(loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt
write-chan
(lambda (pr)
(cond
[((queue-size text-to-insert) . < . buffer-full)
(loop (enqueue pr text-to-insert))]
[else
(let ([chan (make-channel)])
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes (channel-put-evt chan (void)))
(channel-get chan)
(loop remaining-queue)))])))))))))
(let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond
[((queue-size text-to-insert) . < . output-buffer-full)
(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)))
(channel-get chan)
(loop remaining-queue (current-inexact-milliseconds))))]))))))))))
(field [in-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 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 err-sd set-delta-foreground (make-object color% 255 0 0))
(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
;;
(define-struct queue (eles count))
(define (empty-queue) (make-queue '() 0))
(define (enqueue e q) (make-queue (append (queue-eles q) (list e))
(+ (queue-count q) 1)))
(define-struct queue (front back count))
(define (empty-queue) (make-queue '() '() 0))
(define (enqueue e q) (make-queue
(cons e (queue-front q))
(queue-back q)
(+ (queue-count q) 1)))
(define (queue-first q)
(let ([eles (queue-eles q)])
(if (null? eles)
(flip-around q)
(let ([back (queue-back q)])
(if (null? back)
(error 'queue-first "empty queue")
(car eles))))
(car back))))
(define (queue-rest q)
(let ([eles (queue-eles q)])
(if (null? eles)
(flip-around q)
(let ([back (queue-back q)])
(if (null? back)
(error 'queue-rest "empty queue")
(make-queue (cdr eles)
(make-queue (queue-front q)
(cdr back)
(- (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))
;; queue->list : (queue x) -> (listof x)
;; 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