fixed bugs
original commit: 3e5f48bc441f19e85b12ca39c5222cc111cfe879
This commit is contained in:
Robby Findler
parent
4455d2f769
commit
76fd8605bc
|
|
@ -31,7 +31,6 @@
|
|||
[auto-save-error? #f])
|
||||
(public
|
||||
[get-file (lambda (d)
|
||||
'(printf "d: ~aget-filename:~a ~n" d (send this get-filename))
|
||||
(let ([v (mred:finder:get-file d)])
|
||||
(if v
|
||||
v
|
||||
|
|
@ -188,6 +187,7 @@
|
|||
[super-after-delete after-delete]
|
||||
[super-after-set-size-constraint after-set-size-constraint])
|
||||
(public
|
||||
[autowrap-bitmap mred:icon:autowrap-bitmap]
|
||||
[after-load-file
|
||||
(lambda (sucessful?)
|
||||
(when sucessful?
|
||||
|
|
@ -400,7 +400,7 @@
|
|||
range-rectangles)))])
|
||||
(sequence
|
||||
(apply super-init args)
|
||||
(set-autowrap-bitmap mred:icon:autowrap-bitmap)
|
||||
(set-autowrap-bitmap autowrap-bitmap)
|
||||
(let ([keymap (get-keymap)])
|
||||
(mred:keymap:set-keymap-error-handler keymap)
|
||||
(mred:keymap:set-keymap-implied-shifts keymap)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(define mred:finder@
|
||||
(unit/sig mred:finder^
|
||||
(import [mred:debug : mred:debug^]
|
||||
[mred:container : mred:container^]
|
||||
[mred:preferences : mred:preferences^]
|
||||
[mzlib:string : mzlib:string^]
|
||||
[mzlib:function : mzlib:function^]
|
||||
|
|
@ -36,317 +37,330 @@
|
|||
[else #f])))
|
||||
|
||||
(define finder-dialog%
|
||||
(class wx:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
(class mred:container:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
result-box start-dir
|
||||
start-name prompt
|
||||
file-filter file-filter-msg)
|
||||
(inherit
|
||||
new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
(inherit new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 500]
|
||||
|
||||
dirs current-dir
|
||||
last-selected
|
||||
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
(set! current-dir dir)
|
||||
(set! last-directory dir)
|
||||
(let-values
|
||||
([(dir-list menu-list)
|
||||
(let loop ([this-dir dir]
|
||||
[dir-list ()]
|
||||
[menu-list ()])
|
||||
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
|
||||
(if (eq? wx:platform 'windows)
|
||||
(mzlib:string:string-lowercase! in-dir))
|
||||
(let* ([dir-list (cons this-dir dir-list)]
|
||||
[menu-list (cons in-dir menu-list)])
|
||||
(if base-dir
|
||||
(loop base-dir dir-list menu-list)
|
||||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs dir-list)
|
||||
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices menu-list])
|
||||
(unless (null? choices)
|
||||
(send dir-choice append (car choices))
|
||||
(loop (cdr choices))))
|
||||
(send dir-choice set-selection (sub1 (length dirs)))
|
||||
(send dir-choice set-size -1 -1 -1 -1))
|
||||
|
||||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 500]
|
||||
|
||||
dirs current-dir
|
||||
last-selected
|
||||
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
(set! current-dir dir)
|
||||
(set! last-directory dir)
|
||||
(let-values
|
||||
([(dir-list menu-list)
|
||||
(let loop ([this-dir dir]
|
||||
[dir-list ()]
|
||||
[menu-list ()])
|
||||
(let-values ([(base-dir in-dir dir?) (split-path this-dir)])
|
||||
(if (eq? wx:platform 'windows)
|
||||
(mzlib:string:string-lowercase! in-dir))
|
||||
(let* ([dir-list (cons this-dir dir-list)]
|
||||
[menu-list (cons in-dir menu-list)])
|
||||
(if base-dir
|
||||
(loop base-dir dir-list menu-list)
|
||||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs dir-list)
|
||||
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices menu-list])
|
||||
(unless (null? choices)
|
||||
(send dir-choice append (car choices))
|
||||
(loop (cdr choices))))
|
||||
(send dir-choice set-selection (sub1 (length dirs)))
|
||||
(send dir-choice set-size -1 -1 -1 -1))
|
||||
|
||||
(send name-list clear)
|
||||
(send name-list set
|
||||
(mzlib:function:quicksort
|
||||
(let loop ([l (directory-list dir)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([s (car l)]
|
||||
[rest (loop (cdr l))])
|
||||
(if (directory-exists? (build-path dir s))
|
||||
(cons
|
||||
(string-append s
|
||||
(case wx:platform
|
||||
(unix "/")
|
||||
(windows "\\")
|
||||
(macintosh ":")))
|
||||
rest)
|
||||
(if (or (not file-filter)
|
||||
(mzlib:string:regexp-match-exact? file-filter s))
|
||||
(cons s rest)
|
||||
rest)))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))])
|
||||
|
||||
(public
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-goto
|
||||
(opt-lambda (button event [default ""])
|
||||
(let ([orig-dir (wx:get-text-from-user
|
||||
"Directory" "Go to Directory"
|
||||
default)])
|
||||
(if (string? orig-dir)
|
||||
(let ([dir (mzlib:file:normalize-path orig-dir current-dir)])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory dir)
|
||||
(begin
|
||||
(wx:message-box
|
||||
(string-append "Bad directory: " dir)
|
||||
"Error")
|
||||
(do-goto button event orig-dir)))))))]
|
||||
|
||||
[on-default-action
|
||||
(lambda (which)
|
||||
(if (eq? which name-list)
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
[dir (build-path current-dir
|
||||
(make-relative which))])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory (mzlib:file:normalize-path dir))
|
||||
(if save-mode?
|
||||
(send name-field set-value which)
|
||||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok)))))
|
||||
(if (eq? which name-field)
|
||||
(do-ok))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
(let loop ([n (sub1 select-counter)][result ()])
|
||||
(if (< n 0)
|
||||
(begin
|
||||
(set-box! result-box result)
|
||||
(show #f))
|
||||
(loop (sub1 n)
|
||||
(cons (send result-list get-string n)
|
||||
result))))
|
||||
(let ([name
|
||||
(send name-list clear)
|
||||
(send name-list set
|
||||
(mzlib:function:quicksort
|
||||
(let loop ([l (directory-list dir)])
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ([s (car l)]
|
||||
[rest (loop (cdr l))])
|
||||
(if (directory-exists? (build-path dir s))
|
||||
(cons
|
||||
(string-append s
|
||||
(case wx:platform
|
||||
(unix "/")
|
||||
(windows "\\")
|
||||
(macintosh ":")))
|
||||
rest)
|
||||
(if (or (not file-filter)
|
||||
(mzlib:string:regexp-match-exact? file-filter s))
|
||||
(cons s rest)
|
||||
rest)))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))])
|
||||
|
||||
(public
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
[do-goto
|
||||
(opt-lambda (button event [default ""])
|
||||
(let ([orig-dir (wx:get-text-from-user
|
||||
"Directory" "Go to Directory"
|
||||
default)])
|
||||
(if (string? orig-dir)
|
||||
(let ([dir (mzlib:file:normalize-path orig-dir current-dir)])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory dir)
|
||||
(begin
|
||||
(wx:message-box
|
||||
(string-append "Bad directory: " dir)
|
||||
"Error")
|
||||
(do-goto button event orig-dir)))))))]
|
||||
|
||||
[on-default-action
|
||||
(lambda (which)
|
||||
(if (eq? which name-list)
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
[dir (build-path current-dir
|
||||
(make-relative which))])
|
||||
(if (directory-exists? dir)
|
||||
(set-directory (mzlib:file:normalize-path dir))
|
||||
(if save-mode?
|
||||
(send name-field set-value which)
|
||||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok)))))
|
||||
(if (eq? which name-field)
|
||||
(do-ok))))]
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
(let loop ([n (sub1 select-counter)][result ()])
|
||||
(if (< n 0)
|
||||
(begin
|
||||
(set-box! result-box result)
|
||||
(show #f))
|
||||
(loop (sub1 n)
|
||||
(cons (send result-list get-string n)
|
||||
result))))
|
||||
(let ([name
|
||||
(if save-mode?
|
||||
(send name-field get-value)
|
||||
(send name-list get-string-selection))])
|
||||
(cond
|
||||
[(not (string? name)) 'nothing-selected]
|
||||
[(string=? name "")
|
||||
(wx:message-box "You must specify a file name"
|
||||
"Error")]
|
||||
[(and save-mode?
|
||||
file-filter
|
||||
(not (mzlib:string:regexp-match-exact? file-filter name)))
|
||||
(wx:message-box file-filter-msg "Error")]
|
||||
[else
|
||||
(let ([file (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? file)
|
||||
(if save-mode?
|
||||
(send name-field get-value)
|
||||
(send name-list get-string-selection))])
|
||||
(cond
|
||||
[(not (string? name)) 'nothing-selected]
|
||||
[(string=? name "")
|
||||
(wx:message-box "You must specify a file name"
|
||||
"Error")]
|
||||
[(and save-mode?
|
||||
file-filter
|
||||
(not (mzlib:string:regexp-match-exact? file-filter name)))
|
||||
(wx:message-box file-filter-msg "Error")]
|
||||
[else
|
||||
(let ([file (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? file)
|
||||
(if save-mode?
|
||||
(wx:message-box
|
||||
"That is the name of a directory."
|
||||
"Error")
|
||||
(set-directory (mzlib:file:normalize-path file)))
|
||||
(if (or (not save-mode?)
|
||||
(not (file-exists? file))
|
||||
replace-ok?
|
||||
(= (wx:message-box
|
||||
(string-append
|
||||
"The file "
|
||||
name
|
||||
" already exists. "
|
||||
"Replace it?")
|
||||
"Warning"
|
||||
wx:const-yes-no)
|
||||
wx:const-yes))
|
||||
(begin
|
||||
(set-box! result-box (mzlib:file:normalize-path file))
|
||||
(show #f)))))]))))]
|
||||
|
||||
[add-one
|
||||
(lambda (name)
|
||||
(unless (or (directory-exists? name)
|
||||
(> (send result-list find-string name) -1))
|
||||
(set! select-counter (add1 select-counter))
|
||||
(send result-list append (mzlib:file:normalize-path name))))]
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(let ([name (send name-list get-string n)])
|
||||
(if (and (string? name)
|
||||
(positive? (string-length name)))
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(if (< n select-counter)
|
||||
(if (send result-list selected? n)
|
||||
(begin
|
||||
(send result-list delete n)
|
||||
(set! select-counter (sub1 select-counter))
|
||||
(loop n))
|
||||
(loop (add1 n))))))]
|
||||
|
||||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
|
||||
[on-close (lambda () #f)])
|
||||
(sequence
|
||||
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT)
|
||||
|
||||
(make-object wx:message% this prompt)
|
||||
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[dir-choice (make-object wx:choice%
|
||||
this do-dir '() -1 -1 -1 -1
|
||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||
|
||||
[name-list (begin
|
||||
(new-line)
|
||||
(make-object wx:list-box%
|
||||
this do-name-list
|
||||
() wx:const-single
|
||||
-1 -1
|
||||
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
||||
() wx:const-needed-sb))]
|
||||
|
||||
[result-list
|
||||
(if multi-mode?
|
||||
(make-object wx:list-box%
|
||||
this do-result-list
|
||||
()
|
||||
(if (eq? wx:window-system 'motif)
|
||||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
() wx:const-needed-sb))])
|
||||
(sequence
|
||||
(new-line))
|
||||
|
||||
(private
|
||||
[name-field
|
||||
(if save-mode?
|
||||
(let ([v (make-object wx:text%
|
||||
this do-name
|
||||
"Name: " ""
|
||||
-1 -1
|
||||
400 -1
|
||||
wx:const-process-enter)])
|
||||
(if (string? start-name)
|
||||
(send v set-value start-name))
|
||||
(new-line)
|
||||
v))]
|
||||
[into-dir-button
|
||||
(if save-mode?
|
||||
(make-object wx:button%
|
||||
this do-into-dir "Open Directory"))]
|
||||
[goto-button (make-object wx:button%
|
||||
this do-goto "Go to Directory...")]
|
||||
[add-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-add
|
||||
"Add"))]
|
||||
[add-all-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-add-all
|
||||
"Add All"))]
|
||||
[remove-button (if multi-mode?
|
||||
(make-object wx:button%
|
||||
this do-remove
|
||||
"Remove"))])
|
||||
(sequence
|
||||
(if multi-mode?
|
||||
(tab 40)
|
||||
(tab 100)))
|
||||
(private
|
||||
[cancel-button (make-object wx:button%
|
||||
this do-cancel
|
||||
"Cancel")]
|
||||
[ok-button
|
||||
(let ([w (send cancel-button get-width)])
|
||||
(make-object wx:button%
|
||||
this do-ok
|
||||
"OK" -1 -1 w))])
|
||||
(sequence
|
||||
(fit)
|
||||
|
||||
(cond
|
||||
[(and start-dir
|
||||
(not (null? start-dir))
|
||||
(directory-exists? start-dir))
|
||||
(set-directory (mzlib:file:normalize-path start-dir))]
|
||||
[last-directory (set-directory last-directory)]
|
||||
[else (set-directory (current-directory))])
|
||||
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t))))
|
||||
(wx:message-box
|
||||
"That is the name of a directory."
|
||||
"Error")
|
||||
(set-directory (mzlib:file:normalize-path file)))
|
||||
(if (or (not save-mode?)
|
||||
(not (file-exists? file))
|
||||
replace-ok?
|
||||
(= (wx:message-box
|
||||
(string-append
|
||||
"The file "
|
||||
name
|
||||
" already exists. "
|
||||
"Replace it?")
|
||||
"Warning"
|
||||
wx:const-yes-no)
|
||||
wx:const-yes))
|
||||
(begin
|
||||
(set-box! result-box (mzlib:file:normalize-path file))
|
||||
(show #f)))))]))))]
|
||||
|
||||
[add-one
|
||||
(lambda (name)
|
||||
(unless (or (directory-exists? name)
|
||||
(> (send result-list find-string name) -1))
|
||||
(set! select-counter (add1 select-counter))
|
||||
(send result-list append (mzlib:file:normalize-path name))))]
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(let ([name (send name-list get-string n)])
|
||||
(if (and (string? name)
|
||||
(positive? (string-length name)))
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
(if (< n select-counter)
|
||||
(if (send result-list selected? n)
|
||||
(begin
|
||||
(send result-list delete n)
|
||||
(set! select-counter (sub1 select-counter))
|
||||
(loop n))
|
||||
(loop (add1 n))))))]
|
||||
|
||||
[do-cancel
|
||||
(lambda args
|
||||
(set-box! result-box #f)
|
||||
(show #f))]
|
||||
|
||||
[on-close (lambda () #f)])
|
||||
(sequence
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT))
|
||||
|
||||
(private
|
||||
[main-panel (make-object mred:container:vertical-panel% this)]
|
||||
[top-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
[_ (make-object mred:container:message% top-panel prompt)]
|
||||
[dir-choice (make-object mred:container:choice%
|
||||
top-panel do-dir '() -1 -1 -1 -1
|
||||
'("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
|
||||
|
||||
[middle-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
[left-middle-panel (make-object mred:container:vertical-panel% middle-panel)]
|
||||
[right-middle-panel (make-object mred:container:vertical-panel% middle-panel)]
|
||||
[name-list (begin
|
||||
(new-line)
|
||||
(make-object mred:container:list-box%
|
||||
left-middle-panel do-name-list
|
||||
() wx:const-single
|
||||
-1 -1
|
||||
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
||||
() wx:const-needed-sb))]
|
||||
[save-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
[bottom-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
[result-list
|
||||
(if multi-mode?
|
||||
(make-object mred:container:list-box%
|
||||
right-middle-panel do-result-list
|
||||
()
|
||||
(if (eq? wx:window-system 'motif)
|
||||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
() wx:const-needed-sb))]
|
||||
[add-panel (make-object mred:container:horizontal-panel% left-middle-panel)]
|
||||
[remove-panel (make-object mred:container:horizontal-panel% right-middle-panel)])
|
||||
(sequence
|
||||
(send add-panel stretchable-in-y #f)
|
||||
(send remove-panel stretchable-in-y #f)
|
||||
(send name-list stretchable-in-x #t)
|
||||
(when multi-mode?
|
||||
(send result-list stretchable-in-x #t))
|
||||
(send top-panel stretchable-in-y #f)
|
||||
(send bottom-panel stretchable-in-y #f)
|
||||
(send save-panel stretchable-in-y #f))
|
||||
|
||||
(private
|
||||
[name-field
|
||||
(when save-mode?
|
||||
(let ([v (make-object mred:container:text%
|
||||
save-panel do-name
|
||||
"Name: " ""
|
||||
-1 -1
|
||||
400 -1
|
||||
wx:const-process-enter)])
|
||||
(send v stretchable-in-x #t)
|
||||
(if (string? start-name)
|
||||
(send v set-value start-name))
|
||||
(new-line)
|
||||
v))]
|
||||
[into-dir-button
|
||||
(when save-mode?
|
||||
(make-object mred:container:button%
|
||||
save-panel do-into-dir "Open Directory"))]
|
||||
[goto-button (make-object mred:container:button%
|
||||
bottom-panel do-goto "Go to Directory...")]
|
||||
[add-button (when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% add-panel)
|
||||
(make-object mred:container:button%
|
||||
add-panel do-add
|
||||
"Add"))]
|
||||
[add-all-button (when multi-mode?
|
||||
(begin0
|
||||
(make-object mred:container:button%
|
||||
add-panel do-add-all
|
||||
"Add All")
|
||||
(make-object mred:container:horizontal-panel% add-panel)))]
|
||||
[remove-button (when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% remove-panel)
|
||||
(begin0
|
||||
(make-object mred:container:button%
|
||||
remove-panel do-remove
|
||||
"Remove")
|
||||
(make-object mred:container:horizontal-panel% remove-panel)))])
|
||||
(sequence
|
||||
(make-object mred:container:vertical-panel% bottom-panel))
|
||||
(private
|
||||
[cancel-button (make-object mred:container:button%
|
||||
bottom-panel do-cancel
|
||||
"Cancel")]
|
||||
[ok-button
|
||||
(let ([w (send cancel-button get-width)])
|
||||
(make-object mred:container:button%
|
||||
bottom-panel do-ok
|
||||
"OK" -1 -1 w))])
|
||||
(sequence
|
||||
(cond
|
||||
[(and start-dir
|
||||
(not (null? start-dir))
|
||||
(directory-exists? start-dir))
|
||||
(set-directory (mzlib:file:normalize-path start-dir))]
|
||||
[last-directory (set-directory last-directory)]
|
||||
[else (set-directory (current-directory))])
|
||||
|
||||
(center wx:const-both)
|
||||
|
||||
(show #t))))
|
||||
|
||||
(define common-put-file
|
||||
(opt-lambda ([name ()][directory ()][replace? #f]
|
||||
|
|
|
|||
|
|
@ -178,11 +178,7 @@
|
|||
(let* ([main (make-object mred:vertical-panel% parent)]
|
||||
[make-check
|
||||
(lambda (callback title initial-value)
|
||||
(let* ([h (make-object mred:horizontal-panel% main)]
|
||||
[c (make-object mred:check-box% h callback title)]
|
||||
[p (make-object mred:horizontal-panel% h)])
|
||||
(send* h (spacing 1) (border 1))
|
||||
(send* p (spacing 1) (border 1))
|
||||
(let* ([c (make-object mred:check-box% main callback title)])
|
||||
(send c set-value initial-value)))])
|
||||
(send main spacing 1)
|
||||
(make-check (lambda (_ command)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user