(module filedialog mzscheme
  (require mzlib/class
	   mzlib/etc
	   mzlib/list
	   (prefix wx: "kernel.ss")
	   (prefix wx: "wxme/style.ss")
	   (prefix wx: "wxme/cycle.ss")
	   "lock.ss"
	   "wx.ss"
	   "cycle.ss"
	   "check.ss"
	   "mrtop.ss"
	   "path-dialog.ss")

  (provide get-file
	   get-file-list
	   put-file
	   get-directory)

  (define (files->list s)
    (let ([s (open-input-bytes s)])
      (let loop ()
	(let ([n (read s)])
	  (if (eof-object? n)
	      null
	      (begin
		(read-byte s) ; drop space
		(cons (read-bytes n s)
		      (loop))))))))

  (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 (or std? (eq? (system-type) 'unix))
          (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)
          (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" "*.*")))

  ;; 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))
