make gtk file dialog place nicely

original commit: d34d3969d90e2ed1ab57e13b98ec7819beb32850

collects/mred/private/filedialog.rkt

@@ -53,9 +53,8 @@
       (let* ([std? (memq 'common style)]
              [style (if std? (remq 'common style) style)])
         (if (or std? 
-                ;#t ; for now, always use the manually constructed dialog
+                ;; no Cocoa dialog, yet:
-                ;; the platform dialog is only available for Gtk
+                (eq? (system-type) 'macosx))
-                (not (eq? (system-type) 'unix)))
           (send (new path-dialog%
                   [put?      put?]
                   [dir?      dir?]

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

@@ -0,0 +1,146 @@
+#lang racket/base
+(require ffi/unsafe
+         "../../syntax.rkt"
+         "../../lock.rkt"
+         racket/class
+         racket/match
+         "types.rkt"
+         "utils.rkt"
+         "widget.rkt"
+         "queue.rkt"
+         "../common/handlers.rkt"
+         "../common/queue.rkt")
+
+(provide file-selector)
+
+(define _GtkFileChooserDialog _GtkWidget)
+(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))
+;; 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 (show-dialog dlg
+                                      (lambda (v)
+                                        (or (not (= v -3))
+                                            ;; FIXME: for get mode, probably should check file vs.
+                                            ;;  directory name
+                                            (not (eq? type 'put))
+                                            (not (file-exists? (gtk_file_chooser_get_filename dlg)))
+                                            ;; FIXME: need to ask "replace the file? here
+                                            #t))))
+                   (if (eq? type 'multi)
+                       (gtk_file_chooser_get_filenames dlg)
+                       (gtk_file_chooser_get_filename dlg))))
+  (gtk_widget_destroy dlg)
+  ans)
+
+(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean))
+
+(define-signal-handler connect-response "response"
+  (_fun _GtkWidget _int _pointer -> _void)
+  (lambda (gtk id data)
+    (let* ([p (ptr-ref data _racket)]
+           [response-sema (car p)]
+           [response-box (cdr p)])
+      (set-box! response-box id)
+      (semaphore-post response-sema))))
+
+(define (show-dialog dlg-gtk
+                     [validate? (lambda (val) #t)])
+  (let* ([response-sema (make-semaphore)]
+         [response-box (box #f)]
+         [cell (malloc-immobile-cell (cons response-sema
+                                           response-box))])
+    (connect-response dlg-gtk cell)
+    (gtk_widget_show dlg-gtk)
+    (let loop ()
+      (yield response-sema)
+      (unless (validate? (unbox response-box))
+        (loop)))
+    (free-immobile-cell cell) ;; FIXME : don't leak
+    (gtk_widget_hide dlg-gtk)
+    (unbox response-box)))
+
+(define (id-to-menu-item i) i)
+(define-unimplemented get-the-x-selection)
+(define-unimplemented get-the-clipboard)
+(define-unimplemented show-print-setup)
+(define (can-show-print-setup?) #f)

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

@@ -4,12 +4,11 @@
          "../../lock.rkt"
          racket/class
          racket/draw
-         racket/match
+         "filedialog.rkt"
          "types.rkt"
          "utils.rkt"
          "widget.rkt"
-         "../common/handlers.rkt"
+         "../common/handlers.rkt")
-         "../common/queue.rkt")
 
 (provide
  special-control-key
@@ -81,7 +80,10 @@
 (define (set-dialogs . args) (void))
 (define (set-executer e) (void))
 (define-unimplemented send-event)
-(define-unimplemented file-creator-and-type)
+(define file-creator-and-type
+  (case-lambda
+   [(path cr ty) (void)]
+   [(path) (values #"????" #"????")]))
 (define (begin-refresh-sequence) (void))
 (define (end-refresh-sequence) (void))
 (define-unimplemented run-printout)
@@ -124,113 +126,6 @@
 
 (define-unimplemented is-color-display?)
 
-(define _GtkFileChooserDialog _GtkWidget)
-(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))
-;; 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 (show-dialog dlg))
-                   (if (eq? type 'multi)           
-                       (gtk_file_chooser_get_filenames dlg)
-                       (gtk_file_chooser_get_filename dlg))))
-  (gtk_widget_destroy dlg)
-  ans)
-
-(define response-sema (make-semaphore))
-(define response-val #f)
-
-(define-signal-handler connect-response "response"
-  (_fun _GtkWidget _int -> _void)
-  (lambda (gtk id)
-    (set! response-val id)
-    (semaphore-post response-sema)))
-
-(define (show-dialog dlg-gtk)
-  (connect-response dlg-gtk)
-  (gtk_widget_show dlg-gtk)
-  (yield response-sema)
-  (gtk_widget_hide dlg-gtk)
-  response-val)
-
 (define (id-to-menu-item i) i)
 (define-unimplemented get-the-x-selection)
 (define-unimplemented get-the-clipboard)

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

@@ -62,6 +62,7 @@
 
 (define-mz scheme_get_fdset (_fun _pointer _int -> _pointer))
 (define-mz scheme_fdset (_fun _pointer _int -> _void))
+(define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void))
 
 (define (install-wakeup fds)
   (pre-event-sync #t)
@@ -70,7 +71,9 @@
                                  timeout
                                  poll-fds
                                  poll-fd-count)])
-    ;; FIXME: use the `timeout' result
+    (let ([to (ptr-ref timeout _int)])
+      (when (to . >= . 0)
+        (scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to))))
     (if (n . > . poll-fd-count)
         (begin
           (set! poll-fds (malloc _GPollFD n))