From b5529b001ef425c19a55a9cab1767d6339f9c376 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 May 2006 18:09:34 +0000 Subject: [PATCH] reorganize code to make it easier to improve the unix file dialog svn: r3063 original commit: 479db765e7166127ec043fee66ca2636f845f762 --- collects/mred/private/filedialog.ss | 302 ++++------------------------ 1 file changed, 36 insertions(+), 266 deletions(-) diff --git a/collects/mred/private/filedialog.ss b/collects/mred/private/filedialog.ss index ef56014f..a91a8966 100644 --- a/collects/mred/private/filedialog.ss +++ b/collects/mred/private/filedialog.ss @@ -1,31 +1,19 @@ (module filedialog mzscheme (require (lib "class.ss") - (lib "class100.ss") (lib "etc.ss") - (lib "list.ss") (prefix wx: "kernel.ss") "lock.ss" "wx.ss" "cycle.ss" "check.ss" - "helper.ss" - "editor.ss" "mrtop.ss" - "mrcanvas.ss" - "mrpopup.ss" - "mrmenu.ss" - "mritem.ss" - "mrpanel.ss" - "mrtextfield.ss" - "messagebox.ss") + "file-getter.ss") (provide get-file get-file-list put-file get-directory) - (define last-visted-directory #f) - (define (files->list s) (let ([s (open-input-bytes s)]) (let loop () @@ -57,265 +45,47 @@ (string? (cadr p)))) filters)) (raise-type-error who "list of 2-string lists" filters)) - (if (not (or (eq? (system-type) 'unix) - force-unix?)) - (let ([s (wx:file-selector message directory filename extension - ;; file types: - (apply string-append - (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) - filters)) - ;; style: - (cons - (cond - [dir? 'dir] - [put? 'put] - [multi? 'multi] - [else 'get]) - style) - ;; parent: - (and parent (mred->wx parent)))]) - (if (and multi? s) - (map bytes->path (files->list (path->bytes s))) - s)) - (letrec ([ok? #f] - [typed-name #f] - [dir (or (and directory (if (string? directory) - (string->path directory) - directory)) - last-visted-directory - (current-directory))] - [f (make-object dialog% (if dir? "Select Directory" (if put? "Save" "Open")) parent 500 300)] - [__ (when message - (let ([p (make-object vertical-pane% f)]) - (send p stretchable-height #f) - (make-object message% (protect& message) p)))] - [dir-pane (instantiate horizontal-pane% (f) (stretchable-height #f))] - [m (make-object message% (protect& (path->string dir)) dir-pane)] - [lp (make-object horizontal-pane% f)] - [change-dir (lambda (d) (let ([sd (send d get-string-selection)]) - (when sd - (set! dir (simplify-path (build-path dir sd))) - (reset-directory))))] - [dirs (make-object (class list-box% - (define/override (on-subwindow-char w e) - (cond - [(and (send e get-meta-down) - (eq? (send e get-key-code) 'down)) - (change-dir w)] - [(and (send e get-meta-down) - (eq? (send e get-key-code) 'up)) - (send dirs set-selection 0) - (change-dir dirs)] - [else - (super on-subwindow-char w e)])) - (super-instantiate ())) - #f null lp (lambda (d e) - (update-ok) - (when (eq? (send e get-event-type) 'list-box-dclick) - (change-dir d))))] - [dir-paths null] - [files (make-object list-box% #f null lp (lambda (d e) - (update-ok) - (when (eq? (send e get-event-type) 'list-box-dclick) - (done))) - (if multi? '(multiple) '(single)))] - [file-paths null] - [do-text-name (lambda () - (let ([v (send dir-text get-value)]) - (if (or dir? (directory-exists? v)) - (begin - (set! dir (string->path v)) - (reset-directory)) - ;; Maybe specifies a file: - (let-values ([(super file) - (with-handlers ([void #f]) - (let-values ([(base name dir?) (split-path v)]) - (let ([super (and (not dir?) - (or (and (path? base) - (directory-exists? base) - base) - (and (eq? base 'relative) - (directory-exists? dir) dir)))]) - (if super - (values super name) - (values #f #f)))))]) - (if super - (begin - (set! dir super) - (set! typed-name file) - (done)) - (begin - (set! dir (string->path v)) - (reset-directory)))))))] - [dir-text (make-object text-field% #f f (lambda (t e) - (if (eq? (send e get-event-type) 'text-field-enter) - (do-text-name) - (begin - ; typing in the box; disable the lists and enable ok - (send dirs enable #f) - (send files enable #f) - (when create-button - (send create-button enable #t)) - (send ok-button enable #t)))))] - [bp (make-object horizontal-pane% f)] - [dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))] - [spacer (make-object vertical-pane% bp)] - [create-button (and dir? (make-object button% "Create" bp - (lambda (b e) - (with-handlers ([void - (lambda (exn) - (message-box "Error" - (exn-message exn) - f - '(ok stop)))]) - (make-directory (send dir-text get-value)) - (do-text-name)))))] - [cancel-button (make-object button% "Cancel" bp (lambda (b e) (set! ok? #f) (send f show #f)))] - [ok-button (make-object button% - (if dir? "Goto" "OK") - bp (lambda (b e) - (if (send (if dir? dirs files) is-enabled?) - ;; normal mode - (if dir? - (change-dir dirs) - (done)) - ;; handle typed text - (do-text-name))) - '(border))] - [update-ok (lambda () (send ok-button enable (not (null? (send (if dir? dirs files) get-selections)))))] - [select-this-dir (and dir? - (make-object button% "<- &Select" dir-pane - (lambda (b e) - (send f show #f) - (done))))] - [path-string-localestring p1) (path->string p2)))] - [reset-directory (lambda () - (wx:begin-busy-cursor) - (let ([dir-exists? (directory-exists? dir)]) - (send m set-label (protect& - (if dir-exists? - (begin - (unless directory - (set! last-visted-directory dir)) - (path->string dir)) - (string-append "BAD DIRECTORY: " (path->string dir))))) - (when select-this-dir - (send select-this-dir enable dir-exists?)) - (when create-button - (send create-button enable (not dir-exists?)))) - (send dir-text set-value (path->string dir)) - (let ([l (with-handlers ([void (lambda (x) null)]) - (directory-list dir))] - [dot? (send dot-check get-value)]) - (let-values ([(ds fs) - (let loop ([l l][ds null][fs null]) - (cond - [(null? l) (values (cons (string->path "..") - (sort ds path-string-localestring (car l)) 0) #\.)) - (loop (cdr l) ds fs)] - [(file-exists? (build-path dir (car l))) (loop (cdr l) ds (cons (car l) fs))] - [else (loop (cdr l) (cons (car l) ds) fs)]))]) - (set! dir-paths ds) - (send dirs set (map path->string ds)) - (set! file-paths fs) - (send files set (map path->string fs)) - (send dirs enable #t) - (unless dir? - (send files enable #t)) - (update-ok) - (wx:end-busy-cursor))))] - [get-filename (lambda () - (if dir? - dir - (let ([mk (lambda (f) (simplify-path (build-path dir f)))]) - (let ([l (map mk (if typed-name - (list typed-name) - (map (lambda (p) (list-ref (if dir? dir-paths file-paths) p)) - (send (if dir? dirs files) get-selections))))]) - (if multi? l (car l))))))] - [done (lambda () - (let ([name (get-filename)]) - (unless (and put? (file-exists? name) - (eq? (message-box "Warning" - (format "Replace ~s?" (path->string name) ) - f '(yes-no)) - 'no) - (set! typed-name #f)) - (set! ok? #t) - (send f show #f))))]) - (send bp stretchable-height #f) - (send m stretchable-width #t) - (reset-directory) - (when filename - (when (string? filename) - (set! filename (string->path filename))) - (let ([d (send dir-text get-value)]) - (send dir-text set-value (path->string (build-path d filename))) - (set! typed-name filename) - (send ok-button enable #t))) - (when put? - (send dir-text focus)) - (when dir? - (send files enable #f)) - (send f center) - (send f show #t) - (and ok? (get-filename)))))) - - ; We duplicate the case-lambda for `get-file', `get-file-list', and `put-file' so that they have the - ; right arities and names + (if (or (eq? (system-type) 'unix) force-unix?) + (file-getter put? multi? dir? message parent directory filename) + (let ([s (wx:file-selector + message directory filename extension + ;; file types: + (apply string-append + (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) + filters)) + ;; style: + (cons (cond [dir? 'dir] + [put? 'put] + [multi? 'multi] + [else 'get]) + style) + ;; parent: + (and parent (mred->wx parent)))]) + (if (and multi? s) + (map bytes->path (files->list (path->bytes s))) + s))))) (define default-filters '(("Any" "*.*"))) - (define get-file - (case-lambda - [() (get-file #f #f #f #f #f null)] - [(message) (get-file message #f #f #f #f null)] - [(message parent) (get-file message parent #f #f #f null)] - [(message parent directory) (get-file message parent directory #f #f null)] - [(message parent directory filename) (get-file message parent directory filename #f null)] - [(message parent directory filename extension) (get-file message parent directory filename extension null)] - [(message parent directory filename extension style) - (get-file message parent directory filename extension style default-filters)] - [(message parent directory filename extension style filters) - ((mk-file-selector 'get-file #f #f #f #f) message parent directory filename extension style filters)])) + ;; We duplicate the case-lambda for `get-file', `get-file-list', and + ;; `put-file' so that they have the right arities and names - (define get-file-list - (case-lambda - [() (get-file-list #f #f #f #f #f null)] - [(message) (get-file-list message #f #f #f #f null)] - [(message parent) (get-file-list message parent #f #f #f null)] - [(message parent directory) (get-file-list message parent directory #f #f null)] - [(message parent directory filename) (get-file-list message parent directory filename #f null)] - [(message parent directory filename extension) (get-file-list message parent directory filename extension null)] - [(message parent directory filename extension style) - (get-file-list message parent directory filename extension style default-filters)] - [(message parent directory filename extension style filters) - ((mk-file-selector 'get-file-list #f #t #f #f) message parent directory filename extension style filters)])) + (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 #f) + message parent directory filename extension style filters)))])) - (define put-file - (case-lambda - [() (put-file #f #f #f #f #f null)] - [(message) (put-file message #f #f #f #f null)] - [(message parent) (put-file message parent #f #f #f null)] - [(message parent directory) (put-file message parent directory #f #f null)] - [(message parent directory filename) (put-file message parent directory filename #f null)] - [(message parent directory filename extension) (put-file message parent directory filename extension null)] - [(message parent directory filename extension style) - (put-file message parent directory filename extension style default-filters)] - [(message parent directory filename extension style filters) - ((mk-file-selector 'put-file #t #f #f #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 - (case-lambda - [() (get-directory #f #f #f null)] - [(message) (get-directory message #f #f null)] - [(message parent) (get-directory message parent #f null)] - [(message parent directory) (get-directory message parent directory null)] - [(message parent directory style) - ((mk-file-selector 'get-directory #f #f #t #f) message parent directory #f #f style null)])) + (opt-lambda ([message #f] [parent #f] [directory #f] [style null]) + ((mk-file-selector 'get-directory #f #f #t #f) + message parent directory #f #f style null))) (set-get-file! get-file))