removed custom dialog, use the common dialogs from mred

svn: r3473

original commit: d540970a9ac7f02e53821533ab22eade4e580d04
This commit is contained in:
Eli Barzilay 2006-06-25 22:58:23 +00:00
parent e69befce41
commit 871de46799

View File

@ -21,7 +21,7 @@
(rename [-put-file put-file]
[-get-file get-file])
(define dialog-parent-parameter (make-parameter #f))
(define filter-match?
@ -32,635 +32,13 @@
(begin
(message-box (string-constant error) msg)
#f)))))
(define (set-last-directory dir) (preferences:set 'framework:last-directory dir))
(define (get-last-directory) (preferences:get 'framework:last-directory))
(define make-relative
(λ (s) s))
(define build-updir
(λ (dir)
(let-values ([(base _1 _2) (split-path dir)])
(or base dir))))
(define default-filters (make-parameter '(("Any" "*.*"))))
(define default-extension (make-parameter ""))
; the finder-dialog% class controls the user interface for dialogs
(define finder-dialog%
(class dialog%
(init parent-win)
(init-field save-mode?)
(init-field replace-ok?)
(init-field multi-mode?)
(init-field result-box)
(init start-dir)
(init start-name)
(init prompt)
(init-field file-filter)
(init-field file-filter-msg)
(inherit center show)
(define default-width 500)
(define default-height 400)
(define dirs #f)
(define current-dir #f)
(define/private set-listbox-directory ; sets directory in listbox
(λ (dir) ; dir is normalized
(when (directory-exists? dir)
(gui-utils:show-busy-cursor
(λ ()
(set! current-dir dir)
(set-last-directory dir)
(let-values
([(dir-list menu-list)
(let loop ([this-dir dir]
[dir-list null]
[menu-list null])
(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 (path->string in-dir) menu-list)])
(if base-dir
(loop base-dir dir-list menu-list)
; No more
(values dir-list menu-list)))))])
(set! dirs (reverse dir-list))
(send dir-choice clear)
(let loop ([choices (reverse menu-list)])
(unless (null? choices)
(send dir-choice append (car choices))
(loop (cdr choices))))
(send dir-choice set-selection 0))
(send name-list clear)
(send name-list set
(sort
(let ([no-periods?
(not (preferences:get
'framework:show-periods-in-dirlist))])
(let loop ([l (directory-list dir)])
(if (null? l)
null
(let ([s (car l)]
[rest (loop (cdr l))])
(cond
[(and no-periods?
(let ([str (path->string s)])
(<= 1 (string-length str))
(char=? (string-ref str 0) #\.)))
rest]
[(directory-exists? (build-path dir s))
(cons (path->string s) rest)]
[(or (not file-filter)
(regexp-match-exact? file-filter (path->string s)))
(cons (path->string s)
rest)]
[else rest])))))
string<?))
(send name-list set-selection-and-edit 0))))))
(define/private set-edit
(λ ()
(let* ([file (send name-list get-string-selection)])
(send directory-field set-value
(path->string
(if file
(build-path current-dir file)
current-dir))))))
[define/public do-period-in/exclusion
(λ (check-box event)
(preferences:set
'framework:show-periods-in-dirlist
(send check-box get-value))
(set-listbox-directory current-dir))]
[define/public do-dir
(λ (choice event)
(let ([which (send choice get-selection)])
(if (< which (length dirs))
(set-listbox-directory (list-ref dirs which)))))]
[define/public do-name-list
(λ (list-box evt)
(if (eq? (send evt get-event-type) 'list-box-dclick)
(let ([dir (send directory-field get-value)])
(if (directory-exists? dir)
(set-listbox-directory (normal-case-path (normalize-path dir)))
(if multi-mode?
(do-add)
(do-ok))))
(when (send list-box get-string-selection)
(set-edit))))]
[define/public do-result-list
(λ () #f)]
[define/public do-ok
(λ args
(if multi-mode?
(let loop ([n (sub1 (send result-list get-number))]
[result null])
(if (< n 0)
(begin
(set-box! result-box result)
(show #f))
(loop (sub1 n)
(cons (send result-list get-string n)
result))))
; not multi-mode
(let ([name (send name-list get-string-selection)]
[non-empty? (> (send name-list get-number) 0)])
(cond
[(and save-mode?
non-empty?
(not (string? name))) 'nothing-selected]
[(and save-mode?
non-empty?
(string=? name ""))
(let ([file (send directory-field get-value)])
(if (directory-exists? file)
(set-listbox-directory (normal-case-path (normalize-path file)))
(message-box
(string-constant error)
(string-constant must-specify-a-filename))))]
[(and save-mode?
non-empty?
file-filter
(not (regexp-match-exact? file-filter name)))
(message-box (string-constant error) file-filter-msg)]
[else
; if dir in edit box, go to that dir
(let ([dir-name (send directory-field get-value)])
(if (directory-exists? dir-name)
(set-listbox-directory (normal-case-path (normalize-path dir-name)))
; otherwise, try to return absolute path
(let* ([relative-name (make-relative name)]
[file-in-edit (file-exists? dir-name)]
[file (if (or file-in-edit
(not relative-name)
save-mode?)
dir-name
(build-path current-dir relative-name))])
; trying to open a file that doesn't exist
(if (and (not save-mode?) (not file-in-edit))
(message-box
(string-constant error)
(format (string-constant file-does-not-exist) dir-name))
; saving a file, which may exist, or
; opening an existing file
(if (or (not save-mode?)
(not (file-exists? file))
replace-ok?
(eq? (message-box
(string-constant warning)
(format
(string-constant ask-because-file-exists)
file)
#f
'(yes-no))
'yes))
(let ([normal-path
(with-handlers
([(λ (_) #t)
(λ (_)
(message-box
(string-constant warning)
(format
(string-constant dne-or-cycle)
file))
#f)])
(normal-case-path
(normalize-path file)))])
(when normal-path
(set-box! result-box normal-path)
(show #f))))))))]))))]
[define/public add-one
(λ (name)
(unless (or (directory-exists? name)
(send result-list find-string name))
(send result-list append
(normal-case-path (normalize-path name)))))]
[define/public do-add
(λ ()
(let ([name (send name-list get-string-selection)])
(if (string? name)
(let ([name (build-path current-dir
(make-relative name))])
(add-one name)))))]
[define/public do-add-all
(λ ()
(let loop ([n 0])
(when (< n (send name-list get-number))
(let ([name (send name-list get-string n)])
(let ([name (build-path current-dir
(make-relative name))])
(add-one name)
(loop (add1 n)))))))]
[define/public do-remove
(λ ()
(let loop ([n 0])
(if (< n (send result-list get-number))
(if (send result-list is-selected? n)
(begin
(send result-list delete n)
(loop n))
(loop (add1 n))))))]
[define/public do-cancel
(λ ()
(set-box! result-box #f)
(show #f))]
(define/augment on-close (λ () #f))
(super-new (label (if save-mode?
(string-constant put-file)
(string-constant get-file)))
(parent parent-win)
(width default-width)
(height default-height)
(style '(resize-border)))
[define main-panel (make-object vertical-panel% this)]
[define top-panel (make-object horizontal-panel% main-panel)]
(make-object message% prompt top-panel)
[define dir-choice (make-object choice% #f null top-panel
(λ (choice event) (do-dir choice event)))]
[define middle-panel (make-object horizontal-panel% main-panel)]
[define left-middle-panel (make-object vertical-panel% middle-panel)]
[define right-middle-panel (when multi-mode?
(make-object vertical-panel% middle-panel))]
[define name-list%
(class list-box%
(inherit
get-string-selection
get-string
get-selection
get-number
get-first-visible-item
number-of-visible-items
set-first-visible-item
set-selection)
(define/override (on-subwindow-char _ key)
(let ([code (send key get-key-code)]
[num-items (get-number)]
[curr-pos (get-selection)])
(cond
[(or (equal? code 'numpad-return)
(equal? code #\return))
(if multi-mode?
(do-add)
(do-ok))]
; look for letter at beginning of a filename
[(char? code)
(let ([next-matching
(let loop ([pos (add1 curr-pos)])
(cond
[(>= pos num-items) #f]
[else
(let ([first-char (string-ref (get-string pos) 0)])
(if (char-ci=? code first-char)
pos
(loop (add1 pos))))]))])
(if next-matching
(set-selection-and-edit next-matching)
;; didn't find anything forward; start again at front of list
(let loop ([pos 0]
[last-before 0])
(cond
[(<= pos num-items)
(let ([first-char (string-ref (get-string pos) 0)])
(cond
[(char-ci=? code first-char)
(set-selection-and-edit pos)]
[(char-ci<=? first-char code)
(loop (+ pos 1)
pos)]
[else
(set-selection-and-edit last-before)]))]
[else (set-selection-and-edit last-before)]))))]
; movement keys
[(and (eq? code 'up)
(> curr-pos 0))
(set-selection-and-edit (sub1 curr-pos))]
[(and (eq? code 'down)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[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-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-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-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))))]
[else #f])))
[define/public set-selection-and-edit
(λ (pos)
(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-visible-item pos))
(set-selection pos)))
(set-edit))]
[define/public on-default-action
(λ ()
(when (> (get-number) 0)
(let* ([which (get-string-selection)]
[dir (build-path current-dir
(make-relative which))])
(if (directory-exists? dir)
(set-listbox-directory (normal-case-path
(normalize-path dir)))
(if multi-mode?
(do-add)
(do-ok))))))]
(super-new))]
[define name-list (make-object name-list%
#f null left-middle-panel (λ (x y) (do-name-list x y))
'(single))]
[define save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
[define directory-panel (make-object horizontal-panel% main-panel)]
[define dot-panel (when (eq? 'unix (system-type))
(make-object horizontal-panel% main-panel))]
[define bottom-panel (make-object horizontal-panel% main-panel)]
[define directory-field
(keymap:call/text-keymap-initializer
(λ ()
(make-object text-field%
(string-constant full-pathname)
directory-panel
(λ (txt evt)
(when (eq? (send evt get-event-type) 'text-field-enter)
(let ([dir (send directory-field get-value)])
(if (directory-exists? dir)
(set-listbox-directory (normal-case-path
(normalize-path dir)))
(if multi-mode?
(do-add)
(do-ok)))))))))]
[define result-list
(when multi-mode?
(make-object list-box%
#f
null
right-middle-panel
(λ (x y) (do-result-list))
'(multiple)))]
[define add-panel
(when multi-mode?
(make-object horizontal-panel% left-middle-panel))]
[define remove-panel
(when multi-mode?
(make-object horizontal-panel% right-middle-panel))]
[define/private do-updir
(λ ()
(set-listbox-directory (build-updir current-dir))
(set-focus-to-name-list))]
[define/private set-focus-to-name-list
(λ ()
(send name-list focus))]
(when (eq? (system-type) 'unix)
(let ([dot-cb
(make-object check-box%
(string-constant show-dot-files)
dot-panel
(λ (x y) (do-period-in/exclusion x y)))])
(send dot-panel stretchable-height #f)
(send dot-cb set-value
(preferences:get 'framework:show-periods-in-dirlist))))
(send directory-panel stretchable-height #f)
(when multi-mode?
(send add-panel stretchable-height #f)
(send remove-panel stretchable-height #f)
(send result-list stretchable-width #t))
(make-object button%
(string-constant up-directory-button-label)
top-panel
(λ (button evt) (do-updir)))
(send dir-choice stretchable-width #t)
(send name-list stretchable-width #t)
(send top-panel stretchable-height #f)
(send bottom-panel stretchable-height #f)
(when save-mode?
(send save-panel stretchable-height #f))
[define add-button (when multi-mode?
(make-object horizontal-panel% add-panel)
(make-object button%
(string-constant add-button-label)
add-panel
(λ (x y) (do-add))))]
[define add-all-button (when multi-mode?
(begin0
(make-object button%
(string-constant add-all-button-label)
add-panel
(λ (x y) (do-add-all)))
(make-object horizontal-panel% add-panel)))]
[define remove-button (when multi-mode?
(make-object horizontal-panel% remove-panel)
(begin0
(make-object button%
(string-constant remove-button-label)
remove-panel
(λ (x y) (do-remove)))
(make-object horizontal-panel% remove-panel)))]
(make-object vertical-panel% bottom-panel)
[define ok-button
(make-object button% (string-constant ok) bottom-panel
(λ (x y) (do-ok))
(if multi-mode? '() '(border)))]
[define cancel-button (make-object button%
(string-constant cancel)
bottom-panel
(λ (x y) (do-cancel)))]
(make-object grow-box-spacer-pane% bottom-panel)
(cond
[(and start-dir
(directory-exists? start-dir))
(set-listbox-directory (normal-case-path
(normalize-path start-dir)))]
[(get-last-directory)
=>
(λ (dir)
(set-listbox-directory dir))]
[else (set-listbox-directory (current-directory))])
(send ok-button min-width (send cancel-button get-width))
(center 'both)
(show #t)))
; make-common takes a dialog-maker
; used to make one dialog object per session, now created each time
(define make-common
(λ (make-dialog)
(λ args
(let ([result-box (box #f)])
(apply make-dialog result-box args)
(unbox result-box)))))
; the common versions of these functions have their visual
; interfaces under Scheme control
(define common-put-file
(make-common
(opt-lambda (result-box
[name #f]
[in-directory #f]
[replace? #f]
[prompt (string-constant select-file)]
[filter #f]
[filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not in-directory)
(string? name))
(path-only name)
in-directory)]
[saved-directory (get-last-directory)]
[name (or (and (string? name)
(file-name-from-path name))
name)])
(new finder-dialog%
(parent-win parent-win)
(save-mode? #t)
(replace-ok? replace?)
(multi-mode? #f)
(result-box result-box )
(start-dir directory)
(start-name name)
(prompt prompt)
(file-filter filter)
(file-filter-msg filter-msg))
(when in-directory (set-last-directory saved-directory))))))
(define common-get-file
(make-common
(opt-lambda
(result-box
[directory #f]
[prompt (string-constant select-file)]
[filter #f]
[filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)])
(let ([saved-directory (get-last-directory)])
(new finder-dialog%
(parent-win parent-win)
(save-mode? #f)
(replace-ok? #f)
(multi-mode? #f)
(result-box result-box)
(start-dir directory)
(start-name #f)
(prompt prompt)
(file-filter filter)
(file-filter-msg filter-msg))
(when directory (set-last-directory saved-directory))))))
(define common-get-file-list
(make-common
(opt-lambda (result-box
[directory #f]
[prompt (string-constant select-files)]
[filter #f]
[filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)])
(new finder-dialog%
(parent-win parent-win)
(save-mode? #f)
(replace-ok? #f)
(multi-mode? #t)
(result-box result-box)
(start-dir directory)
(start-name #f)
(prompt prompt)
(file-filter filter)
(file-filter-msg filter-msg)))))
; the std- and common- forms both have opt-lambda's, with the same
; list of args. Should the opt-lambda's be placed in the dispatching function?
;; dialog wrappers
(define std-put-file
(define (*put-file style)
(opt-lambda ([name #f]
[directory #f]
[replace? #f]
@ -674,7 +52,7 @@
[name (or (and (string? name) (file-name-from-path name))
name)]
[f (put-file prompt parent-win directory name
(default-extension) '() (default-filters))])
(default-extension) style (default-filters))])
(and f (or (not filter) (filter-match? filter f filter-msg))
(let* ([f (normal-case-path (normalize-path f))]
[dir (path-only f)]
@ -690,13 +68,13 @@
#f]
[else f]))))))
(define std-get-file
(define (*get-file style)
(opt-lambda ([directory #f]
[prompt (string-constant select-file)]
[filter #f]
[filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)])
(let ([f (get-file prompt parent-win directory)])
(let ([f (get-file prompt parent-win directory #f #f style)])
(and f (or (not filter) (filter-match? filter f filter-msg))
(let ([f (normalize-path f)])
(cond [(directory-exists? f)
@ -711,13 +89,18 @@
;; external interfaces to file functions
(define std-put-file (*put-file '()))
(define std-get-file (*get-file '()))
(define common-put-file (*put-file '(common)))
(define common-get-file (*get-file '(common)))
(define common-get-file-list void)
(define -put-file
(λ args
(apply (case (preferences:get 'framework:file-dialogs)
[(std) std-put-file]
[(common) common-put-file])
args)))
(define -get-file
(λ args
(apply (case (preferences:get 'framework:file-dialogs)