suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make gtk file dialog place nicely

Browse Source 
original commit: d34d3969d90e2ed1ab57e13b98ec7819beb32850
This commit is contained in:
Matthew Flatt 2010-08-06 21:19:56 -06:00
parent 3737a96791
commit d4de5ceb8e
4 changed files with 158 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/filedialog.rkt
View File

@ -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
;; the platform dialog is only available for Gtk
(not (eq? (system-type) 'unix)))
;; no Cocoa dialog, yet:
(eq? (system-type) 'macosx))
(send (new path-dialog%
[put? put?]
[dir? dir?]

146
collects/mred/private/wx/gtk/filedialog.rkt Normal file
View File

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

117
collects/mred/private/wx/gtk/procs.rkt
View File

@ -4,12 +4,11 @@
"../../lock.rkt"
racket/class
racket/draw
racket/match
"filedialog.rkt"
"types.rkt"
"utils.rkt"
"widget.rkt"
"../common/handlers.rkt"
"../common/queue.rkt")
"../common/handlers.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)

5
collects/mred/private/wx/gtk/queue.rkt
View File

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