Implement GTK-native file selector

collects/mred/private/filedialog.rkt

@@ -50,11 +50,13 @@
 				  (string? (cadr p))))
 			   filters))
 	(raise-type-error who "list of 2-string lists" filters))
+      (printf "parent window: ~a ~a\n" parent (and parent (mred->wx parent)))
       (let* ([std? (memq 'common style)]
              [style (if std? (remq 'common style) style)])
         (if (or std? 
-                #t ; for now, always use the manually constructed dialog
-                (eq? (system-type) 'unix))
+                ;#t ; for now, always use the manually constructed dialog
+                ;; the platform dialog is only available for Gtk
+                (not (eq? (system-type) 'unix)))
           (send (new path-dialog%
                   [put?      put?]
                   [dir?      dir?]
@@ -71,6 +73,8 @@
           (let ([s (wx:file-selector
                     message directory filename extension
                     ;; file types:
+                    filters
+                    #;
                     (apply string-append
                            (map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
                                 filters))

collects/mred/private/wx/gtk/procs.rkt

@@ -4,8 +4,10 @@
          "../../lock.rkt"
          racket/class
          racket/draw
+         racket/match
          "types.rkt"
          "utils.rkt"
+         "widget.rkt"
          "../common/handlers.rkt")
 
 (provide
@@ -61,7 +63,6 @@
  show-print-setup
  can-show-print-setup?)
 
-
 (define-unimplemented special-control-key)
 (define-unimplemented special-option-key)
 (define-unimplemented get-color-from-user)
@@ -121,7 +122,99 @@
 (define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count)))))
 
 (define-unimplemented is-color-display?)
-(define-unimplemented file-selector)
+
+(define _GtkFileChooserDialog (_cpointer 'GtkFileChooserDialog))
+(define _GtkFileChooser (_cpointer 'GtkFileChooser))
+(define _GtkFileChooserAction 
+  (_enum (list 'open 'save 'select-folder 'create-folder)))
+
+(define _GtkResponse
+  (_enum 
+   '(none = -1
+     reject = -2
+     accept = -3
+     delete-event = -4
+     ok = -5
+     cancel = -6
+     close = -7
+     yes = -8
+     no = -9
+     apply = -10
+     help = -11)
+   _fixint))
+(define _GtkDialog (_cpointer 'GtkDialog))
+;; FIXME: really there are varargs here, but we don't need them for
+;; our purposes
+(define-gtk gtk_file_chooser_dialog_new 
+  (_fun _string (_or-null _GtkWindow) 
+        _GtkFileChooserAction
+        _string _GtkResponse
+        _string _GtkResponse
+        (_or-null _pointer)
+        -> _GtkFileChooserDialog))
+;; FIXME - should really be _GtkDialog but no subtyping
+(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int))
+;; FIXME ;; these should really be _GtkFileChooser but no subtyping
+(define-gtk gtk_file_chooser_get_filename 
+  (_fun _GtkFileChooserDialog -> _gpath/free))
+(define-gtk gtk_file_chooser_get_filenames
+  (_fun _GtkFileChooserDialog -> (_GSList _gpath/free)))
+(define-gtk gtk_file_chooser_set_current_name
+  (_fun _GtkFileChooserDialog _path -> _void))
+(define-gtk gtk_file_chooser_set_current_folder
+  (_fun _GtkFileChooserDialog _path -> _void))
+(define-gtk gtk_file_chooser_set_select_multiple
+  (_fun _GtkFileChooserDialog _gboolean -> _void))
+
+(define _GtkFileFilter (_cpointer 'GtkFileFilter))
+(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter))
+(define-gtk gtk_file_filter_set_name
+  (_fun _GtkFileFilter _string -> _void))
+(define-gtk gtk_file_filter_add_pattern
+  (_fun _GtkFileFilter _string -> _void))
+
+(define-gtk gtk_file_chooser_add_filter
+  (_fun _GtkFileChooserDialog _GtkFileFilter -> _void))
+
+(define (file-selector message directory filename 
+                       extension ;; always ignored
+                       filters style parent)
+  (define type (car style)) ;; the rest of `style' is irrelevant on Gtk
+  (define dlg (gtk_file_chooser_dialog_new 
+               message (and parent (send parent get-gtk))
+               (case type
+                 [(dir) 'select-directory]
+                 [(put) 'save]
+                 [else 'open])
+               "gtk-cancel" 'cancel
+               ;; no stock names for "Select"
+               (case type
+                 [(dir) "Choose"]
+                 [(put) "gtk-save"]
+                 [(get) "gtk-open"]
+                 [(multi) "Choose"])
+               'accept
+               #f))
+  (when (eq? 'multi type)
+    (gtk_file_chooser_set_select_multiple dlg #t))
+  (when filename
+    (gtk_file_chooser_set_current_name dlg filename))
+  (when directory
+    (gtk_file_chooser_set_current_folder dlg directory))
+  (for ([f (in-list filters)])
+    (match f
+      [(list name glob)
+       (let ([ff (gtk_file_filter_new)])
+         (gtk_file_filter_set_name ff name)
+         (gtk_file_filter_add_pattern ff glob)
+         (gtk_file_chooser_add_filter dlg ff))]))
+  (define ans (and (= -3 (gtk_dialog_run dlg))
+                   (if (eq? type 'multi)           
+                       (gtk_file_chooser_get_filenames dlg)
+                       (gtk_file_chooser_get_filename dlg))))
+  (gtk_widget_destroy dlg)
+  ans)
+
 (define (id-to-menu-item i) i)
 (define-unimplemented get-the-x-selection)
 (define-unimplemented get-the-clipboard)

collects/mred/private/wx/gtk/utils.rkt

@@ -1,6 +1,7 @@
 #lang scheme/base
 (require ffi/unsafe
          ffi/unsafe/define
+         (only-in '#%foreign ctype-c->scheme)
          "../common/utils.rkt"
          "types.rkt")
 
@@ -15,6 +16,10 @@
          g_object_ref
          g_object_unref
 
+         g_free
+         _gpath/free
+         _GSList
+
          g_object_set_data
          g_object_get_data
 
@@ -77,6 +82,8 @@
 (define-gobj g_object_ref (_fun _pointer -> _void))
 (define-gobj g_object_unref (_fun _pointer -> _void))
 
+(define-gobj g_free (_fun _pointer -> _void))
+
 (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
 (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))
 
@@ -115,3 +122,37 @@
       (function-ptr handler-proc (_fun #:atomic? #t . args)))
     (define (connect-name gtk [user-data #f])
       (g_signal_connect gtk signal-name handler_function user-data))))
+
+
+(define _gpath/free
+  (make-ctype _pointer
+              path->bytes ; a Racket bytes can be used as a pointer
+              (lambda (x)
+                (let ([b (bytes->path (make-byte-string x))])
+                  (g_free x)
+                  b))))
+
+(define-cstruct _g-slist
+  ([data _pointer]
+   [next (_or-null _g-slist-pointer)]))
+
+(define-gobj g_slist_free (_fun _g-slist-pointer -> _void))
+;; This should probably be provided by Racket
+(define make-byte-string
+  (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket)))
+
+(define (_GSList elem)
+  (make-ctype (_or-null _g-slist-pointer)
+              (lambda (l)
+                (let L ([l l])
+                  (if (null? l) 
+                      #f
+                      (make-g-slist (car l) (L (cdr l))))))
+              (lambda (gl)
+                (begin0
+                 (let L ([gl gl])
+                   (if (not gl) 
+                       null
+                       (cons ((ctype-c->scheme elem) (g-slist-data gl))
+                             (L (g-slist-next gl)))))
+                 (g_slist_free gl)))))

collects/mred/private/wx/gtk/widget.rkt

@@ -13,6 +13,7 @@
 
          gtk_widget_show
          gtk_widget_hide
+         gtk_widget_destroy
 
          gtk_vbox_new
          gtk_hbox_new
@@ -22,6 +23,9 @@
 (define-gtk gtk_widget_show (_fun _GtkWidget -> _void))
 (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void))
 
+(define-gtk gtk_widget_destroy (_fun _pointer -> _void))
+
+
 (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget))
 (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget))
 (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))