98 lines
3.2 KiB
Racket
98 lines
3.2 KiB
Racket
(module filedialog mzscheme
|
|
(require mzlib/class
|
|
mzlib/etc
|
|
mzlib/list
|
|
(prefix wx: "kernel.ss")
|
|
(prefix wx: racket/snip)
|
|
(rename "wxme/cycle.ss" wx:set-editor-get-file! set-editor-get-file!)
|
|
(rename "wxme/cycle.ss" wx:set-editor-put-file! set-editor-put-file!)
|
|
"lock.ss"
|
|
"wx.ss"
|
|
"cycle.ss"
|
|
"check.ss"
|
|
"mrtop.ss"
|
|
"path-dialog.ss")
|
|
|
|
(provide get-file
|
|
get-file-list
|
|
put-file
|
|
get-directory)
|
|
|
|
(define (mk-file-selector who put? multi? dir?)
|
|
(lambda (message parent directory filename extension style filters)
|
|
;; Calls from C++ have wrong kind of window:
|
|
(when (is-a? parent wx:window%)
|
|
(set! parent (as-entry (lambda () (wx->mred parent)))))
|
|
|
|
(check-label-string/false who message)
|
|
(check-top-level-parent/false who parent)
|
|
(check-path/false who directory)
|
|
(check-path/false who filename)
|
|
(check-string/false who extension)
|
|
(check-style who #f (cond
|
|
[dir? '(common enter-packages)]
|
|
[else '(common packages enter-packages)]) style)
|
|
(unless (and (list? filters)
|
|
(andmap (lambda (p)
|
|
(and (list? p)
|
|
(= (length p) 2)
|
|
(string? (car p))
|
|
(string? (cadr p))))
|
|
filters))
|
|
(raise-type-error who "list of 2-string lists" filters))
|
|
(let* ([std? (memq 'common style)]
|
|
[style (if std? (remq 'common style) style)])
|
|
(if std?
|
|
(send (new path-dialog%
|
|
[put? put?]
|
|
[dir? dir?]
|
|
[multi? multi?]
|
|
[message message]
|
|
[parent parent]
|
|
[directory directory]
|
|
[filename filename]
|
|
[filters
|
|
(cond [(eq? filters default-filters) #t] ; its own defaults
|
|
[dir? #f]
|
|
[else filters])])
|
|
run)
|
|
(wx:file-selector
|
|
message directory filename extension
|
|
;; file types:
|
|
filters
|
|
;; style:
|
|
(cons (cond [dir? 'dir]
|
|
[put? 'put]
|
|
[multi? 'multi]
|
|
[else 'get])
|
|
style)
|
|
;; parent:
|
|
(and parent (mred->wx parent)))))))
|
|
|
|
(define default-filters '(("Any" "*.*")))
|
|
|
|
;; We duplicate the case-lambda for `get-file', `get-file-list', and
|
|
;; `put-file' so that they have the right arities and names
|
|
|
|
(define-syntax define-file-selector
|
|
(syntax-rules ()
|
|
[(_ name put? multi?)
|
|
(define name
|
|
(opt-lambda ([message #f] [parent #f] [directory #f] [filename #f]
|
|
[extension #f] [style null] [filters default-filters])
|
|
((mk-file-selector 'name put? multi? #f)
|
|
message parent directory filename extension style filters)))]))
|
|
|
|
(define-file-selector get-file #f #f)
|
|
(define-file-selector get-file-list #f #t)
|
|
(define-file-selector put-file #t #f)
|
|
|
|
(define get-directory
|
|
(opt-lambda ([message #f] [parent #f] [directory #f] [style null])
|
|
((mk-file-selector 'get-directory #f #f #t)
|
|
message parent directory #f #f style null)))
|
|
|
|
(set-get-file! get-file)
|
|
(wx:set-editor-get-file! get-file)
|
|
(wx:set-editor-put-file! put-file))
|