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

...

Browse Source 
original commit: 5e5497bcd386f0d72e4670ce8dc8a9b5d468b749
This commit is contained in:
Robby Findler 1999-02-15 04:18:08 +00:00
parent e55c276c94
commit 71a0132b23
3 changed files with 105 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
collects/framework/finder.ss
View File

@ -103,8 +103,7 @@
(unless (null? choices)
(send dir-choice append (car choices))
(loop (cdr choices))))
(send dir-choice set-selection 0)
(send top-panel force-redraw))
(send dir-choice set-selection 0))
(send name-list clear)
(send name-list set
@ -135,16 +134,11 @@
[set-edit
(lambda ()
(let* ([file (send name-list get-string-selection)]
[dir-and-file
(let* ([file (send name-list get-string-selection)])
(send directory-field set-value
(if file
(build-path current-dir file)
current-dir)])
(send* directory-edit
(begin-edit-sequence)
(erase)
(insert dir-and-file)
(end-edit-sequence))))])
current-dir))))])
(public
@ -172,7 +166,7 @@
(if multi-mode?
(let ([dir-name (send directory-edit get-text)])
(let ([dir-name (send directory-field get-value)])
(if (directory-exists? dir-name)
(set-directory (mzlib:file:normalize-path dir-name))
(let loop ([n (sub1 select-counter)][result null])
@ -186,7 +180,7 @@
; not multi-mode
(let ([name (send name-list get-string-selection)]
[non-empty? (> (send name-list number) 0)])
[non-empty? (> (send name-list get-number) 0)])
(cond
@ -197,7 +191,7 @@
[(and save-mode?
non-empty?
(string=? name ""))
(let ([file (send directory-edit get-text)])
(let ([file (send directory-field get-value)])
(if (directory-exists? file)
(set-directory (mzlib:file:normalize-path file))
(message-box
@ -214,7 +208,7 @@
; if dir in edit box, go to that dir
(let ([dir-name (send directory-edit get-text)])
(let ([dir-name (send directory-field get-value)])
(if (directory-exists? dir-name)
(set-directory (mzlib:file:normalize-path dir-name))
@ -339,13 +333,13 @@
(class-asi list-box%
(inherit
get-first-item
get-first-visible-item
get-string
get-selection
get-string-selection
number
get-number
number-of-visible-items
set-first-item
set-first-visible-item
focus
set-selection)
@ -354,12 +348,12 @@
[set-selection-and-edit ; set selection, update edit box
(lambda (pos)
(when (> (number) 0)
(let* ([first-item (get-first-item)]
(when (> (get-number) 0)
(let* ([first-item (get-first-visible-item)]
[last-item (sub1 (+ (number-of-visible-items)
first-item))])
(if (or (< pos first-item) (> pos last-item))
(set-first-item pos))
(set-first-visible-item pos))
(set-selection pos)))
(set-edit))]
@ -367,7 +361,7 @@
(lambda (_ key)
(let ([code (send key get-key-code)]
[num-items (number)]
[num-items (get-number)]
[curr-pos (get-selection)])
(cond
@ -377,7 +371,7 @@
(do-ok)]
[(equal? code #\tab)
(set-focus-to-directory-edit)]
(send directory-field focus)]
; look for letter at beginning of a filename
@ -402,26 +396,26 @@
[(and (eq? code 'down)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[curr-first (get-first-item)]
[curr-first (get-first-visible-item)]
[new-curr-pos (add1 curr-pos)]
[new-first (if (< new-curr-pos (+ curr-first num-vis))
curr-first ; no scroll needed
(add1 curr-first))])
(set-first-item new-first)
(set-first-visible-item new-first)
(set-selection-and-edit new-curr-pos))]
[(and (eq? code 'prior)
(> curr-pos 0))
(let* ([num-vis (number-of-visible-items)]
[new-first (- (get-first-item) num-vis)])
(set-first-item (max new-first 0))
[new-first (- (get-first-visible-item) num-vis)])
(set-first-visible-item (max new-first 0))
(set-selection-and-edit (max 0 (- curr-pos num-vis))))]
[(and (eq? code 'next)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[new-first (+ (get-first-item) num-vis)])
(set-first-item (min new-first (- (number) num-vis)))
[new-first (+ (get-first-visible-item) num-vis)])
(set-first-visible-item (min new-first (- (get-number) num-vis)))
(set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))]
@ -429,7 +423,7 @@
[on-default-action
(lambda ()
(when (> (send name-list number) 0)
(when (> (send name-list get-number) 0)
(let* ([which (send name-list get-string-selection)]
[dir (build-path current-dir
(make-relative which))])
@ -440,42 +434,31 @@
(do-ok))))))]))]
[name-list (make-object name-list%
#f left-middle-panel do-name-list
#f null left-middle-panel do-name-list
'(single))]
[set-focus-to-name-list
(lambda ()
(send name-list focus))]
[set-focus-to-directory-edit
(lambda ()
(send directory-panel focus))]
[save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
[directory-panel (make-object horizontal-panel% main-panel)]
[directory-edit
(make-object (class-asi text%
(rename [super-on-local-char on-local-char])
(public
[on-local-char
(lambda (key)
(let ([code (send key get-key-code)])
(cond
[(or (equal? code #\return)
(equal? code 'numpad-enter))
(do-ok)
(set-focus-to-name-list)]
[(equal? code #\tab)
(set-focus-to-name-list)]
[else
(super-on-local-char key)])))])))]
[dot-panel (when (eq? 'unix (system-type))
(make-object horizontal-panel% main-panel))]
[bottom-panel (make-object horizontal-panel% main-panel)]
[directory-field
(make-object text-field%
"Full pathname"
directory-panel
(lambda (evt txt)
(when (eq? (send evt get-type) 'text-enter)
(do-ok))))]
[result-list
(when multi-mode?
(make-object list-box%
@ -501,43 +484,34 @@
(when (eq? (system-type) 'unix)
(let ([dot-cb
(make-object
check-box% dot-panel
do-period-in/exclusion
"Show files and directories that begin with a dot")])
(send dot-panel stretchable-in-y #f)
(make-object check-box%
"Show files and directories that begin with a dot"
dot-panel
do-period-in/exclusion)])
(send dot-panel stretchable-height #f)
(send dot-cb set-value
(preferences:get 'framework:show-periods-in-dirlist))))
(send directory-panel stretchable-in-y #f)
(let ([canvas (make-object editor-canvas% directory-panel #f
(list 'hide-h-scroll 'v-scroll))])
(send* canvas
(set-line-count 1)
(set-media directory-edit)
(focus)
(user-min-height 20)))
(send directory-panel stretchable-height #f)
(when multi-mode?
(send add-panel stretchable-in-y #f)
(send remove-panel stretchable-in-y #f)
(send result-list stretchable-in-x #t))
(send add-panel stretchable-height #f)
(send remove-panel stretchable-height #f)
(send result-list stretchable-width #t))
(make-object button%
"Up directory"
top-panel
(lambda (button evt) (do-updir)))
(send name-list stretchable-in-x #t)
(send name-list stretchable-width #t)
(send top-panel stretchable-in-y #f)
(send top-panel stretchable-height #f)
(send bottom-panel stretchable-in-y #f)
(send bottom-panel stretchable-height #f)
(when save-mode?
(send save-panel stretchable-in-y #f)))
(send save-panel stretchable-height #f)))
(private
@ -632,7 +606,7 @@
[filter-msg "Bad name"]
[parent-win (dialog-parent-parameter)])
(make-object finder-dialog%
parent-win ; parent window
#f;parent-win ; parent window
#f ; save-mode?
#f ; replace-ok?
#f ; multi-mode?

50
collects/tests/framework/frame.ss
View File

@ -83,20 +83,40 @@
'frame:pasteboard-info-file%)
(define (test-open name class-expression)
(test
name
(lambda (x) x)
(lambda ()
(send-sexp-to-mred
`(begin
(preferences:set
'framework:file-dialogs
'common)
(send (make-object ,class-expression "test open") show #t)))
(wait-for-frame "test open")
(send-sexp-to-mred
`(test:menu-select "File" "Open..."))
(wait-for-frame "Open File")
#t)))
(let* ([test-file-contents "test"]
[tmp-file-name "framework-tmp"]
[tmp-file (build-path (collection-path "tests" "framework")
tmp-file-name)])
(test
name
(lambda (x)
(delete-file tmp-file)
(equal? x test-file-contents))
(lambda ()
(send-sexp-to-mred
`(begin
(preferences:set 'framework:file-dialogs 'common)
(send (make-object ,class-expression "test open") show #t)))
(wait-for-frame "test open")
(send-sexp-to-mred
`(test:menu-select "File" "Open..."))
(wait-for-frame "Get file")
(call-with-output-file tmp-file-name
(lambda (port)
(display test-file-contents port))
'truncate)
(send-sexp-to-mred
`(begin (send (find-labelled-window "Full pathname") focus)
(for-each test:keystroke
(string->list ,tmp-file))
(test:keystroke #\return)))
(wait-for-frame (format "framework - ~a" tmp-file-name))
(send-sexp-to-mred
`(let* ([w (get-top-level-focus-window)]
[t (send (send w get-editor) get-text)])
(test:close-window w)
t))))))
(test-open "frame:editor open" 'frame:text%)

43
collects/tests/framework/main.ss
View File

@ -26,6 +26,8 @@
section-name
section-jump))
(require-library "guis.ss" "tests" "utils")
(define TestSuite
(unit/sig internal-TestSuite^
(import (program)
@ -56,6 +58,7 @@
port next)
(loop)))])
(tcp-listen port)))))
(define in-port #f)
(define out-port #f)
@ -72,12 +75,11 @@
(set! out-port out))
(when load-framework-automatically?
(send-sexp-to-mred
'(let ([s (make-semaphore 0)])
(queue-callback (lambda ()
(require-library "framework.ss" "framework")
(test:run-interval 11)
(semaphore-post s)))
(semaphore-wait s))))))
`(begin
(require-library "framework.ss" "framework")
(require-library "gui.ss" "tests" "utils")
(test:run-interval 11))))))
(define load-framework-automatically
(case-lambda
[(new-load-framework-automatically?)
@ -191,21 +193,22 @@
[(continue) (void)]
[else (jump)])))))]))
(define (wait-for sexp)
(let ([timeout 10]
[pause-time 1/2])
(send-sexp-to-mred
`(let loop ([n ,(/ timeout pause-time)])
(if (zero? n)
(error 'wait-for
,(format "after ~a seconds, ~s didn't come true" timeout sexp))
(unless ,sexp
(sleep ,pause-time)
(loop (- n 1))))))))
(define (wait-for sexp)
(let ([timeout 10]
[pause-time 1/2])
(send-sexp-to-mred
`(let loop ([n ,(/ timeout pause-time)])
(if (zero? n)
(error 'wait-for
,(format "after ~a seconds, ~s didn't come true" timeout sexp))
(unless ,sexp
(sleep ,pause-time)
(loop (- n 1))))))))
(define (wait-for-frame name)
(wait-for `(let ([win (get-top-level-focus-window)])
(and win (string=? (send win get-label) ,name)))))))
(define (wait-for-frame name)
(wait-for `(let ([win (get-top-level-focus-window)])
(printf "name: ~a~n" (and win (box (send win get-label))))
(and win (string=? (send win get-label) ,name)))))))
(define Engine
(unit/sig Engine^