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

.

Browse Source 
original commit: 2affb358e2218f7d6a4868d802d99adcbe32decf
This commit is contained in:
Robby Findler 2004-04-14 17:03:45 +00:00
parent 81abad71e8
commit d78b7c0592
2 changed files with 56 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/framework/private/finder.ss
View File

@ -81,12 +81,11 @@
(let loop ([this-dir dir] (let loop ([this-dir dir]
[dir-list null] [dir-list null]
[menu-list null]) [menu-list null])
(let-values ([(base-dir in-dir dir?) (let-values ([(base-dir in-dir dir?) (split-path this-dir)])
(split-path this-dir)]) (when (eq? (system-type) 'windows)
(if (eq? (system-type) 'windows) (string-lowercase! in-dir))
(string-lowercase! in-dir))
(let* ([dir-list (cons this-dir dir-list)] (let* ([dir-list (cons this-dir dir-list)]
[menu-list (cons in-dir menu-list)]) [menu-list (cons (path->string in-dir) menu-list)])
(if base-dir (if base-dir
(loop base-dir dir-list menu-list) (loop base-dir dir-list menu-list)
; No more ; No more
@ -112,27 +111,28 @@
[rest (loop (cdr l))]) [rest (loop (cdr l))])
(cond (cond
[(and no-periods? [(and no-periods?
(<= 1 (string-length s)) (let ([str (path->string s)])
(char=? (string-ref s 0) #\.)) (<= 1 (string-length str))
(char=? (string-ref str 0) #\.)))
rest] rest]
[(directory-exists? (build-path dir s)) [(directory-exists? (build-path dir s))
(cons s rest)] (cons (path->string s) rest)]
[(or (not file-filter) [(or (not file-filter)
(regexp-match-exact? file-filter s)) (regexp-match-exact? file-filter (path->string s)))
(cons s rest)] (cons (path->string s)
rest)]
[else rest]))))) [else rest])))))
;(if (eq? (system-type) 'unix) string<? string-ci<?) string<?))
string-ci<?
))
(send name-list set-selection-and-edit 0)))))) (send name-list set-selection-and-edit 0))))))
(define/private set-edit (define/private set-edit
(lambda () (lambda ()
(let* ([file (send name-list get-string-selection)]) (let* ([file (send name-list get-string-selection)])
(send directory-field set-value (send directory-field set-value
(if file (path->string
(build-path current-dir file) (if file
current-dir))))) (build-path current-dir file)
current-dir))))))
[define/public do-period-in/exclusion [define/public do-period-in/exclusion
(lambda (check-box event) (lambda (check-box event)

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

@ -839,13 +839,16 @@ WARNING: printf is rebound in the body of the unit to always
(define ports<%> (define ports<%>
(interface () (interface ()
get-insertion-point get-insertion-point
set-insertion-point
get-unread-start-point get-unread-start-point
set-unread-start-point set-unread-start-point
set-allow-edits
get-allow-edits
has-between? has-between?
submit-to-port? submit-to-port?
on-submit on-submit
send-eof-to-in-port send-eof-to-in-port
flush-output-ports clear-ports
get-in-port get-in-port
get-out-port get-out-port
get-err-port get-err-port
@ -880,6 +883,11 @@ WARNING: printf is rebound in the body of the unit to always
;; only updated in `eventspace' (above)'s main thread ;; only updated in `eventspace' (above)'s main thread
(define unread-start-point 0) (define unread-start-point 0)
;; allow-edits? : boolean
;; when this flag is set, only insert/delete after the
;; insertion-point are allowed.
(define allow-edits? #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; public interface ;; public interface
@ -900,16 +908,18 @@ WARNING: printf is rebound in the body of the unit to always
(not (= insertion-point unread-start-point))) (not (= insertion-point unread-start-point)))
(define/public (get-insertion-point) insertion-point) (define/public (get-insertion-point) insertion-point)
(define/public (set-insertion-point ip) (set! insertion-point ip))
(define/public (get-unread-start-point) unread-start-point) (define/public (get-unread-start-point) unread-start-point)
(define/public (set-unread-start-point u) (set! unread-start-point u)) (define/public (set-unread-start-point u) (set! unread-start-point u))
(define/public (set-allow-edits allow?) (set! allow-edits? allow?))
(define/public (get-allow-edits) allow-edits?)
(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) (define/public (clear-ports)
(let ([c (make-channel)]) (channel-put clear-output-chan (void))
(channel-put this-eventspace-flush-chan c) (channel-put clear-input-chan (void)))
(let ([viable-bytes (channel-get c)])
(do-insertion viable-bytes))))
(define/public (get-in-port) (define/public (get-in-port)
(unless in-port (error 'get-in-port "not ready")) (unless in-port (error 'get-in-port "not ready"))
@ -941,12 +951,14 @@ WARNING: printf is rebound in the body of the unit to always
(rename [super-can-insert? can-insert?]) (rename [super-can-insert? can-insert?])
(define/override (can-insert? start len) (define/override (can-insert? start len)
(and (super-can-insert? start len) (and (super-can-insert? start len)
(start . >= . insertion-point))) (or allow-edits?
(start . >= . insertion-point))))
(rename [super-can-delete? can-delete?]) (rename [super-can-delete? can-delete?])
(define/override (can-delete? start len) (define/override (can-delete? start len)
(and (super-can-delete? start len) (and (super-can-delete? start len)
(start . >= . insertion-point))) (or allow-edits?
(start . >= . insertion-point))))
(rename [super-on-local-char on-local-char]) (rename [super-on-local-char on-local-char])
(define/override (on-local-char key) (define/override (on-local-char key)
@ -996,10 +1008,10 @@ 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)) ;; clear-output-chan, clear-input-chan : (channel void)
;; used to do syncs on the main eventspace ;; dumps all data and readers making the ports empty again
(define this-eventspace-flush-chan (make-channel)) (define clear-output-chan (make-channel))
(define clear-input-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
@ -1068,6 +1080,10 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (result) (lambda (result)
(channel-put result #t) (channel-put result #t)
(data-waiting data))) (data-waiting data)))
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
read-chan read-chan
(lambda (new-data) (lambda (new-data)
@ -1080,6 +1096,10 @@ WARNING: printf is rebound in the body of the unit to always
(define (readers-waiting readers) (define (readers-waiting readers)
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
peek-chan peek-chan
(lambda (result) (lambda (result)
@ -1104,6 +1124,10 @@ WARNING: printf is rebound in the body of the unit to always
[reader-fail (cdr reader-hd)]) [reader-fail (cdr reader-hd)])
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
peek-chan peek-chan
(lambda (result) (lambda (result)
@ -1119,7 +1143,7 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (v) (lambda (v)
(data-and-readers-waiting data (data-and-readers-waiting data
(queue-rest readers))))))])) (queue-rest readers))))))]))
(data-waiting (empty-queue))))) (data-and-readers-waiting (empty-queue) (empty-queue)))))
(define output-buffer-thread (define output-buffer-thread
(let ([buffer-full 40] (let ([buffer-full 40]
@ -1137,11 +1161,9 @@ WARNING: printf is rebound in the body of the unit to always
(queue-insertion viable-bytes return-waitable) (queue-insertion viable-bytes return-waitable)
(loop remaining-queue)))) (loop remaining-queue))))
(make-wrapped-waitable (make-wrapped-waitable
this-eventspace-flush-chan clear-output-chan
(lambda (return) (lambda (_)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (loop (empty-queue))))
(channel-put return viable-bytes)
(loop remaining-queue))))
(make-wrapped-waitable (make-wrapped-waitable
write-chan write-chan
(lambda (pr) (lambda (pr)