56 lines
1.4 KiB
Racket
56 lines
1.4 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
"types.rkt"
|
|
"utils.rkt"
|
|
"widget.rkt"
|
|
"queue.rkt"
|
|
"../common/queue.rkt")
|
|
|
|
(provide
|
|
(protect-out show-dialog
|
|
_GtkResponse))
|
|
|
|
(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-signal-handler connect-response "response"
|
|
(_fun _GtkWidget _GtkResponse _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))]
|
|
[es (current-eventspace)])
|
|
(connect-response dlg-gtk cell)
|
|
(eventspace-adjust-external-modal! es 1)
|
|
(gtk_widget_show dlg-gtk)
|
|
(let loop ()
|
|
(yield response-sema)
|
|
(unless (validate? (unbox response-box))
|
|
(loop)))
|
|
(eventspace-adjust-external-modal! es -1)
|
|
(free-immobile-cell cell) ;; FIXME : don't leak
|
|
(gtk_widget_hide dlg-gtk)
|
|
(unbox response-box)))
|