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

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

@ -81,12 +81,11 @@
(let loop ([this-dir dir]
[dir-list null]
[menu-list null])
(let-values ([(base-dir in-dir dir?)
(split-path this-dir)])
(if (eq? (system-type) 'windows)
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
(when (eq? (system-type) 'windows)
(string-lowercase! in-dir))
(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
(loop base-dir dir-list menu-list)
; No more
@ -112,27 +111,28 @@
[rest (loop (cdr l))])
(cond
[(and no-periods?
(<= 1 (string-length s))
(char=? (string-ref s 0) #\.))
(let ([str (path->string s)])
(<= 1 (string-length str))
(char=? (string-ref str 0) #\.)))
rest]
[(directory-exists? (build-path dir s))
(cons s rest)]
(cons (path->string s) rest)]
[(or (not file-filter)
(regexp-match-exact? file-filter s))
(cons s rest)]
(regexp-match-exact? file-filter (path->string s)))
(cons (path->string s)
rest)]
[else rest])))))
;(if (eq? (system-type) 'unix) string<? string-ci<?)
string-ci<?
))
string<?))
(send name-list set-selection-and-edit 0))))))
(define/private set-edit
(lambda ()
(let* ([file (send name-list get-string-selection)])
(send directory-field set-value
(path->string
(if file
(build-path current-dir file)
current-dir)))))
current-dir))))))
[define/public do-period-in/exclusion
(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<%>
(interface ()
get-insertion-point
set-insertion-point
get-unread-start-point
set-unread-start-point
set-allow-edits
get-allow-edits
has-between?
submit-to-port?
on-submit
send-eof-to-in-port
flush-output-ports
clear-ports
get-in-port
get-out-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
(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
@ -900,16 +908,18 @@ WARNING: printf is rebound in the body of the unit to always
(not (= insertion-point unread-start-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 (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 (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 (clear-ports)
(channel-put clear-output-chan (void))
(channel-put clear-input-chan (void)))
(define/public (get-in-port)
(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?])
(define/override (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?])
(define/override (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])
(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
(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))
;; clear-output-chan, clear-input-chan : (channel void)
;; dumps all data and readers making the ports empty again
(define clear-output-chan (make-channel))
(define clear-input-chan (make-channel))
;; write-chan : (channel (cons bytes style))
;; send output to the editor
@ -1068,6 +1080,10 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (result)
(channel-put result #t)
(data-waiting data)))
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable
read-chan
(lambda (new-data)
@ -1080,6 +1096,10 @@ WARNING: printf is rebound in the body of the unit to always
(define (readers-waiting readers)
(object-wait-multiple
#f
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable
peek-chan
(lambda (result)
@ -1104,6 +1124,10 @@ WARNING: printf is rebound in the body of the unit to always
[reader-fail (cdr reader-hd)])
(object-wait-multiple
#f
(make-wrapped-waitable
clear-input-chan
(lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable
peek-chan
(lambda (result)
@ -1119,7 +1143,7 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (v)
(data-and-readers-waiting data
(queue-rest readers))))))]))
(data-waiting (empty-queue)))))
(data-and-readers-waiting (empty-queue) (empty-queue)))))
(define output-buffer-thread
(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)
(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))))
clear-output-chan
(lambda (_)
(loop (empty-queue))))
(make-wrapped-waitable
write-chan
(lambda (pr)