#lang scheme/unit

  (require string-constants
           "sig.ss"
           "../preferences.ss"
           mred/mred-sig
           scheme/path)
  
  
  (import mred^
          [prefix keymap: framework:keymap^])
  
  (export (rename framework:finder^
                  [-put-file put-file]
                  [-get-file get-file]))
  
  (define dialog-parent-parameter (make-parameter #f))
  
  (define filter-match?
    (λ (filter name msg)
      (let-values ([(base name dir?) (split-path name)])
        (if (regexp-match-exact? filter (path->bytes name))
            #t
            (begin
              (message-box (string-constant error) msg)
              #f)))))
  
  (define default-filters (make-parameter '(("Any" "*.*"))))
  (define default-extension (make-parameter ""))
  
  ;; dialog wrappers
  
  (define (*put-file style)
    (lambda ([name #f]
             [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 directory) (string? name))
                            (path-only name)
                            directory)]
             [name (or (and (string? name) (file-name-from-path name))
                       name)]
             [f (put-file prompt parent-win directory name
                          (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)]
                    [name (file-name-from-path f)])
               (cond
                 [(not (and (path-string? dir) (directory-exists? dir)))
                  (message-box (string-constant error)
                               (string-constant dir-dne))
                  #f]
                 [(or (not name) (equal? name ""))
                  (message-box (string-constant error)
                               (string-constant empty-filename))
                  #f]
                 [else f]))))))
  
  (define (*get-file style)
    (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 #f #f style)])
        (and f (or (not filter) (filter-match? filter f filter-msg))
             (let ([f (normalize-path f)])
               (cond [(directory-exists? f)
                      (message-box (string-constant error)
                                   (string-constant that-is-dir-name))
                      #f]
                     [(not (file-exists? f))
                      (message-box (string-constant error) 
                                   (string-constant file-dne))
                      #f]
                     [else f]))))))
  
  ;; 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)
               [(std) std-get-file]
               [(common) common-get-file])
             args)))