95 lines
3.4 KiB
Racket
95 lines
3.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
(prefix-in wx: "kernel.rkt")
|
|
(rename-in "wxme/cycle.rkt"
|
|
[set-editor-get-file! wx:set-editor-get-file!]
|
|
[set-editor-put-file! wx:set-editor-put-file!])
|
|
"lock.rkt"
|
|
"wx.rkt"
|
|
"cycle.rkt"
|
|
"check.rkt"
|
|
"mrtop.rkt"
|
|
"path-dialog.rkt")
|
|
|
|
(provide get-file
|
|
get-file-list
|
|
put-file
|
|
get-directory)
|
|
|
|
(define ((mk-file-selector who put? multi? dir?)
|
|
message parent directory filename extension style filters dialog-mixin)
|
|
;; Calls from C++ have wrong kind of window:
|
|
(when (is-a? parent wx:window%)
|
|
(set! parent (as-entry (λ () (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 (λ (p)
|
|
(and (list? p)
|
|
(= (length p) 2)
|
|
(string? (car p))
|
|
(string? (cadr p))))
|
|
filters))
|
|
(raise-argument-error who "(listof (list/c string? string?))" filters))
|
|
(let* ([std? (memq 'common style)]
|
|
[style (if std? (remq 'common style) style)])
|
|
(if std?
|
|
(send (new (dialog-mixin 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 definition 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 [message #f] [parent #f] [directory #f] [filename #f]
|
|
[extension #f] [style null] [filters default-filters]
|
|
#:dialog-mixin [dialog-mixin values])
|
|
((mk-file-selector 'name put? multi? #f)
|
|
message parent directory filename extension style filters dialog-mixin))]))
|
|
|
|
(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 [message #f] [parent #f] [directory #f] [style null] #:dialog-mixin [dialog-mixin values])
|
|
((mk-file-selector 'get-directory #f #f #t)
|
|
message parent directory #f #f style null dialog-mixin))
|
|
|
|
(set-get-file! get-file)
|
|
(wx:set-editor-get-file! get-file)
|
|
(wx:set-editor-put-file! put-file)
|