From e9487fb0c739427fa49f79b4f512fb717ab683a9 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Fri, 3 Jun 2011 00:54:07 -0400
Subject: [PATCH] Make the cocoa file dialogs deal better with ";"-separated
 globs.

* Note the ugly hack of adding "foo~" for every "foo" suffix.

* Note also that when "*.*" is in the glob list all files should be
  available but it looks like this isn't working yet for some reason.
---
 collects/mred/private/wx/cocoa/filedialog.rkt | 41 +++++++++++--------
 1 file changed, 24 insertions(+), 17 deletions(-)

diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt
index cf20e36e09..6d82ccfeff 100644
--- a/collects/mred/private/wx/cocoa/filedialog.rkt
+++ b/collects/mred/private/wx/cocoa/filedialog.rkt
@@ -9,8 +9,7 @@
          "queue.rkt"
          "frame.rkt")
 
-(provide 
- (protect-out file-selector))
+(provide (protect-out file-selector))
 
 (import-class NSOpenPanel NSSavePanel NSURL NSArray)
 
@@ -28,27 +27,35 @@
                      (not (send parent get-sheet))
                      parent)])
 
-    (let ([extensions (append
-                       (if (and extension 
-                                (not (equal? "" extension)))
-                           (list extension) 
-                           null)
-                       (if (memq 'packages style) (list "app") null)
-                       (for/list ([e (in-list filters)]
-                                  #:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e))
-                                              (not (equal? (cadr e) "*.*"))))
-                         (car (regexp-match #rx"[^.]+$" (cadr e)))))])
+    (let* ([globs (apply append
+                         (map (lambda (f) (regexp-split #rx" *; *" (cadr f)))
+                              filters))]
+           ;; get suffixes from "*.foo" globs (and *only* such globs)
+           [extensions
+            (for/list ([g (in-list globs)]
+                       #:when (and (regexp-match #rx"[*][.][^.]+$" g)
+                                   (not (equal? g "*.*"))))
+              (car (regexp-match #rx"[^.]+$" g)))]
+           [extensions
+            (if (memq 'packages style) (cons "app" extensions) extensions)]
+           [extensions
+            (if (and extension (not (equal? "" extension)))
+              (cons extension extensions) extensions)]
+           ;; add "foo~" suffixes too.
+           [extensions
+            (append (for/list ([e (in-list extensions)]
+                               #:when (not (regexp-match? #rx"~$" e)))
+                      (string-append e "~"))
+                    extensions)])
       (unless (null? extensions)
         (when (memq 'put style)
           (tellv ns setCanSelectHiddenExtension: #:type _BOOL #t))
-        (let ([a (tell NSArray 
+        (let ([a (tell NSArray
                        arrayWithObjects: #:type (_list i _NSString) extensions
                        count: #:type _NSUInteger (length extensions))])
           (tellv ns setAllowedFileTypes: a))
-        (let ([others? (ormap (lambda (e)
-                                (equal? (cadr e) "*.*"))
-                              filters)])
-          (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?))))
+        (tellv ns setAllowsOtherFileTypes:
+               #:type _BOOL (and (member "*.*" globs) #t))))
 
     (cond
      [(memq 'multi style)