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

fix on-subwindow- and modal for choice%; suppress other callbacks on set

Browse Source 
original commit: f8ba0a65d2104139bc2ab9b072d6e09f5a8aee5b
This commit is contained in:
Matthew Flatt 2010-08-05 05:48:18 -06:00
parent afee071c5c
commit 21ccccbc3f
7 changed files with 234 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -12,7 +12,8 @@
"window.rkt"
"client-window.rkt"
"widget.rkt"
"dc.rkt")
"dc.rkt"
"combo.rkt")
(provide canvas%)
@ -108,19 +109,20 @@
(GdkRectangle-height r)))
(gdk_gc_unref gc)))))
(define (handle-value-changed-h gtk ignored)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda () (send wx do-scroll 'horizontal))))
#t)
(define handle_value_changed_h
(function-ptr handle-value-changed-h (_fun #:atomic? #t _GtkWidget _pointer -> _void)))
(define-signal-handler connect-value-changed-h "value-changed"
(_fun _GtkWidget -> _void)
(lambda (gtk)
(do-value-changed gtk 'horizontal)))
(define (handle-value-changed-v gtk ignored)
(define-signal-handler connect-value-changed-v "value-changed"
(_fun _GtkWidget -> _void)
(lambda (gtk)
(do-value-changed gtk 'vertical)))
(define (do-value-changed gtk dir)
(let ([wx (gtk->wx gtk)])
(queue-window-event wx (lambda () (send wx do-scroll 'vertical))))
(queue-window-event wx (lambda () (send wx do-scroll dir))))
#t)
(define handle_value_changed_v
(function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void)))
(define-gtk gtk_entry_get_type (_fun -> _GType))
@ -145,7 +147,9 @@
(define virtual-height #f)
(define virtual-width #f)
(define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box)
(define-values (client-gtk gtk
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
combo-button-gtk)
(cond
[(or (memq 'hscroll style)
(memq 'vscroll style))
@ -184,11 +188,12 @@
(values client-gtk h hadj vadj
(and (memq 'hscroll style) h2)
(and (memq 'vscroll style) v2)
(and (memq 'hscroll style) (memq 'vscroll style) resize-box))))]
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
#f)))]
[is-combo?
(let* ([gtk (gtk_combo_box_entry_new_text)]
[orig-entry (gtk_bin_get_child gtk)])
(values orig-entry gtk #f #f #f #f #f))]
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))]
[has-border?
(let ([client-gtk (gtk_drawing_area_new)]
[h (gtk_hbox_new #f 0)])
@ -196,10 +201,10 @@
(gtk_container_set_border_width h margin)
(connect-expose-border h)
(gtk_widget_show client-gtk)
(values client-gtk h #f #f #f #f #f))]
(values client-gtk h #f #f #f #f #f #f))]
[else
(let ([client-gtk (gtk_drawing_area_new)])
(values client-gtk client-gtk #f #f #f #f #f))]))
(values client-gtk client-gtk #f #f #f #f #f #f))]))
(super-new [parent parent]
[gtk gtk]
@ -209,7 +214,9 @@
null
(if hscroll-adj
(list client-gtk hscroll-adj vscroll-adj)
(list client-gtk)))])
(if combo-button-gtk
(list client-gtk combo-button-gtk)
(list client-gtk))))])
(set-size x y w h)
@ -248,18 +255,18 @@
GDK_LEAVE_NOTIFY_MASK))
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
GTK_CAN_FOCUS))
(when combo-button-gtk
(connect-combo-key-and-mouse combo-button-gtk))
(when hscroll-adj
(g_signal_connect hscroll-adj "value-changed" handle_value_changed_h))
(when vscroll-adj
(g_signal_connect vscroll-adj "value-changed" handle_value_changed_v))
(when hscroll-adj (connect-value-changed-h hscroll-adj))
(when vscroll-adj (connect-value-changed-v vscroll-adj))
(define/override (direct-update?) #f)
(define/public (get-dc) dc)
(define/override (get-client-gtk) client-gtk)
(define/override (handles-events?) #t)
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
(define/override (get-client-delta)
(values margin margin))

34
collects/mred/private/wx/gtk/choice.rkt
View File

@ -7,7 +7,9 @@
"types.rkt"
"utils.rkt"
"window.rkt"
"../common/event.rkt")
"combo.rkt"
"../common/event.rkt"
"../common/queue.rkt")
(unsafe!)
(provide choice%)
@ -20,9 +22,6 @@
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void))
(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void))
(define-signal-handler connect-changed "changed"
(_fun _GtkWidget -> _void)
(lambda (gtk)
@ -43,18 +42,7 @@
;; Hack to access the combobox's private child, where is
;; where the keyboard focus goes.
(define button-gtk
(let ([all null]
[ext null])
(gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f)
(gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f)
(for-each (lambda (e)
(set! all (filter (lambda (a) (not (ptr-equal? a e)))
all)))
ext)
(unless (= 1 (length all))
(error "expected Gtk combobox to have one private child"))
(car all)))
(define button-gtk (extract-combo-button gtk))
(super-new [parent parent]
[gtk gtk]
@ -62,14 +50,13 @@
[callback cb]
[no-show? (memq 'deleted style)])
(connect-key-and-mouse button-gtk)
(gtk_combo_box_set_active gtk 0)
(set-auto-size)
(connect-changed gtk)
(connect-focus button-gtk)
(connect-combo-key-and-mouse button-gtk)
(define callback cb)
(define/public (clicked)
@ -94,13 +81,18 @@
(define/public (clear)
(as-entry
(lambda ()
(set! ignore-clicked? #t)
(for ([i (in-range count)])
(gtk_combo_box_remove_text gtk 0))
(set! count 0))))
(define/public (append l)
(set! count 0)
(set! ignore-clicked? #f))))
(public [-append append])
(define (-append l)
(as-entry
(lambda ()
(set! ignore-clicked? #t)
(set! count (add1 count))
(gtk_combo_box_append_text gtk l)
(when (= count 1)
(set-selection 0))))))
(set-selection 0))
(set! ignore-clicked? #f)))))

118
collects/mred/private/wx/gtk/combo.rkt Normal file
View File

@ -0,0 +1,118 @@
#lang scheme/base
(require scheme/foreign
scheme/class
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"window.rkt")
(unsafe!)
;; Hacks for working with GtkComboBox[Entry]
(provide extract-combo-button
connect-combo-key-and-mouse)
;; ----------------------------------------
(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void))
(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void))
(define-gobj g_signal_parse_name (_fun _string
_GType
(id : (_ptr o _uint))
(_ptr o _GQuark)
_gboolean
-> (r : _gboolean)
-> (and r id)))
(define-gobj g_type_from_name (_fun _string -> _GType))
(define _GSignalMatchType _int)
(define _GQuark _uint32)
(define _GClosure _int)
(define-gobj g_signal_handler_find (_fun _GtkWidget
_GSignalMatchType
_uint ; signal_id
_GQuark ; detail
_GClosure ; closure
_pointer ; func
_pointer ; data
-> _ulong))
(define-gobj g_signal_handler_disconnect (_fun _GtkWidget _uint -> _void))
(define-gobj g_signal_handler_block (_fun _GtkWidget _uint -> _void))
(define-gobj g_signal_handler_unblock (_fun _GtkWidget _uint -> _void))
(define-gobj g_signal_emit (_fun _GtkWidget
_uint
_GQuark
_pointer
(r : (_ptr o _gboolean))
-> _void
-> r))
(define G_SIGNAL_MATCH_ID 1)
(define button-press-id #f)
(define unblocked? #f)
(define-signal-handler connect-reorder-button-press "button-press-event"
(_fun _GtkWidget _GdkEventButton-pointer _long -> _gboolean)
(lambda (gtk event other-id)
(if unblocked?
#f
(let ([v (do-button-event gtk event #f #f)])
(or v
(begin
(g_signal_handler_unblock gtk other-id)
(let ([r (g_signal_emit gtk
button-press-id
0
event)])
(g_signal_handler_block gtk other-id)
r)))))))
;; Dependence on the implemenation of GtkComboBox:
;; Keyboard focus and other actions are based on a private button widget
;; inside a GtkComboBox, so we extract it.
(define (extract-combo-button gtk)
(let ([all null]
[ext null])
(gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f)
(gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f)
(for-each (lambda (e)
(set! all (filter (lambda (a) (not (ptr-equal? a e)))
all)))
ext)
(unless (= 1 (length all))
(error "expected Gtk combobox to have one private child"))
(car all)))
;; More dependence on the implemenation of GtkComboBox:
;; The memnu-popup action is implemented by seeting a button-press-event
;; signal handler on `button-gtk'. Since Gtk calls signal handlers in the
;; order that they're registered, our button-press-event handler doesn't
;; get called first, so it can't cancel the button press due to modality
;; or an `on-subwindow-event' result. We effectively reorder the callbacks
;; by finding the old one, blocking it, and then unblocking during a
;; redispatch.
(define (connect-combo-key-and-mouse button-gtk)
(unless button-press-id
(set! button-press-id
(g_signal_parse_name "button-press-event" (g_type_from_name "GtkWidget") #f)))
(let ([hand-id
(and button-press-id
(let ([hand-id (g_signal_handler_find button-gtk
G_SIGNAL_MATCH_ID
button-press-id
0
0
#f
#f)])
(if (zero? hand-id)
#f
(begin
(g_signal_handler_block button-gtk hand-id)
hand-id))))])
(connect-key-and-mouse button-gtk (and hand-id #t))
(when hand-id
(connect-reorder-button-press button-gtk (cast hand-id _long _pointer)))))

75
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -79,9 +79,14 @@
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(for ([s (in-list items)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1))))
(reset-content)
(gtk_list_store_set store iter 0 s -1)))
(maybe-init-select))
(define/private (maybe-init-select)
(when (and (= (get-selection) -1)
(pair? data))
(set-selection 0)))
(define column
(let ([renderer (gtk_cell_renderer_text_new)])
(gtk_tree_view_column_new_with_attributes
@ -119,15 +124,18 @@
(define/override (get-client-gtk) client-gtk)
(define callback cb)
(define ignore-click? #f)
(define/public (queue-changed)
(make-will-executor)
;; Called from event-handling thread
(queue-window-event
this
(lambda ()
(unless (null? items)
(callback this (new control-event%
[event-type 'list-box]
[time-stamp (current-milliseconds)]))))))
(unless ignore-click?
(queue-window-event
this
(lambda ()
(unless (null? items)
(callback this (new control-event%
[event-type 'list-box]
[time-stamp (current-milliseconds)])))))))
(define/private (get-iter i)
(let ([iter (make-GtkTreeIter 0 #f #f #f)]
@ -151,10 +159,14 @@
(gtk_tree_path_free p)))
(define/public (set choices)
(clear)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(reset-content))
(as-entry
(lambda ()
(set! ignore-click? #t)
(clear)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(reset-content)
(set! ignore-click? #f))))
(define/public (get-selections)
(as-entry
@ -206,14 +218,18 @@
(gtk_tree_path_free p))))
(define/public (select i [on? #t] [extend? #t])
(let ([p (gtk_tree_path_new_from_indices i -1)])
(if on?
(begin
(unless extend?
(gtk_tree_selection_unselect_all selection))
(gtk_tree_selection_select_path selection p))
(gtk_tree_selection_unselect_path selection p))
(gtk_tree_path_free p)))
(as-entry
(lambda ()
(set! ignore-click? #t)
(let ([p (gtk_tree_path_new_from_indices i -1)])
(if on?
(begin
(unless extend?
(gtk_tree_selection_unselect_all selection))
(gtk_tree_selection_select_path selection p))
(gtk_tree_selection_unselect_path selection p))
(gtk_tree_path_free p))
(set! ignore-click? #f))))
(define/public (set-selection i)
(select i #t #f))
@ -231,10 +247,15 @@
(public [append* append])
(define (append* s [v #f])
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1))))
(as-entry
(lambda ()
(set! ignore-click? #t)
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1))
(maybe-init-select)
(set! ignore-click? #f))))
(reset-content))

23
collects/mred/private/wx/gtk/slider.rkt
View File

@ -7,7 +7,8 @@
"types.rkt"
"window.rkt"
"const.rkt"
"../common/event.rkt")
"../common/event.rkt"
"../../lock.rkt")
(unsafe!)
(provide slider%)
@ -53,17 +54,23 @@
(connect-changed gtk)
(define callback cb)
(define ignore-click? #f)
(define/public (queue-changed)
;; Called in event-dispatch thread
(gtk_range_set_value gtk (floor (gtk_range_get_value gtk)))
(queue-window-event
this
(lambda ()
(callback this (new control-event%
[event-type 'slider]
[time-stamp (current-milliseconds)])))))
(unless ignore-click?
(queue-window-event
this
(lambda ()
(callback this (new control-event%
[event-type 'slider]
[time-stamp (current-milliseconds)]))))))
(define/public (set-value v)
(gtk_range_set_value gtk v))
(as-entry
(lambda ()
(set! ignore-click? #t)
(gtk_range_set_value gtk v)
(set! ignore-click? #f))))
(define/public (get-value)
(inexact->exact (floor (gtk_range_get_value gtk)))))

11
collects/mred/private/wx/gtk/utils.rkt
View File

@ -17,7 +17,6 @@
g_object_set_data
g_object_get_data
g_signal_connect
g_object_new
@ -81,9 +80,9 @@
(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))
(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer (_pointer = #f) _fnpointer _int -> _ulong))
(define (g_signal_connect obj s proc)
(g_signal_connect_data obj s proc #f 0))
(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong))
(define (g_signal_connect obj s proc user-data)
(g_signal_connect_data obj s proc user-data #f 0))
(define-gobj g_object_get (_fun _GtkWidget (_string = "window")
[w : (_ptr o _GdkWindow)]
@ -114,5 +113,5 @@
(define handler-proc proc)
(define handler_function
(function-ptr handler-proc (_fun #:atomic? #t . args)))
(define (connect-name gtk)
(g_signal_connect gtk signal-name handler_function))))
(define (connect-name gtk [user-data #f])
(g_signal_connect gtk signal-name handler_function user-data))))

11
collects/mred/private/wx/gtk/window.rkt
View File

@ -29,6 +29,7 @@
connect-focus
connect-key-and-mouse
do-button-event
(struct-out GtkRequisition) _GtkRequisition-pointer
(struct-out GtkAllocation) _GtkAllocation-pointer)
@ -96,7 +97,7 @@
[y 0]
[time-stamp (GdkEventKey-time event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events?)
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
#t)
@ -132,10 +133,10 @@
(lambda (gtk event)
(do-button-event gtk event #f #t)))
(define (connect-key-and-mouse gtk)
(define (connect-key-and-mouse gtk [skip-press? #f])
(connect-key-press gtk)
(connect-button-press gtk)
(connect-button-release gtk)
(unless skip-press? (connect-button-release gtk))
(connect-pointer-motion gtk)
(connect-enter gtk)
(connect-leave gtk))
@ -201,7 +202,7 @@
(if crossing? GdkEventCrossing-time GdkEventButton-time))
event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
(if (send wx handles-events?)
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event m #f)))
@ -366,7 +367,7 @@
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))
(define/public (handles-events?) #f)
(define/public (handles-events? gtk) #f)
(define/public (dispatch-on-char e just-pre?)
(cond
[(other-modal? this) #t]