From 543525dc0bad1851d0abe57dc97307fffe205ae1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Jul 2010 13:04:39 -0600 Subject: [PATCH] gtk combo boxes original commit: 37d4cfb14863683e6501a1ba975a933aae3847ba --- collects/mred/private/mrtextfield.rkt | 30 ++--- collects/mred/private/wx/cocoa/canvas.rkt | 3 + collects/mred/private/wx/gtk/canvas.rkt | 127 ++++++++++++++++------ collects/mred/private/wx/gtk/dc.rkt | 7 +- collects/mred/private/wx/gtk/types.rkt | 3 + collects/mred/private/wx/gtk/utils.rkt | 4 + collects/mred/private/wxtextfield.rkt | 14 ++- 7 files changed, 136 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index e76c938c..400acb46 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -110,15 +110,20 @@ [get-menu (lambda () menu)] [append (lambda (item) (check-label-string '(method combo-field% append) item) - (make-object menu-item% item menu - (lambda (i e) - (focus) - (set-value item) - (let ([e (get-editor)]) - (send e set-position 0 (send e last-position))) - (send (as-entry (lambda () (mred->wx this))) - command - (make-object wx:control-event% 'text-field)))))]) + (unless (send (mred->wx this) append-combo-item item + (lambda () (handle-selected item))) + (make-object menu-item% item menu + (lambda (i e) + (handle-selected item)))))]) + (private + [handle-selected (lambda (item) + (focus) + (set-value item) + (let ([e (get-editor)]) + (send e set-position 0 (send e last-position))) + (send (as-entry (lambda () (mred->wx this))) + command + (make-object wx:control-event% 'text-field)))]) (override [on-subwindow-event (lambda (w e) (and (send e button-down?) @@ -130,7 +135,6 @@ (private-field [menu (new popup-menu% [font font])]) (sequence - (for-each (lambda (item) - (append item)) - choices) - (super-init label parent callback init-value (list* combo-flag 'single style)))))) + (super-init label parent callback init-value (list* combo-flag 'single style)) + (for-each (lambda (item) (append item)) + choices))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index ccfed82f..644cb8bf 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -330,6 +330,9 @@ (scroller-page scroller) 1)])) + (define/public (append-combo-item str) #f) + (define/public (on-combo-select i) (void)) + (define bg-col (make-object color% "white")) (define/public (get-canvas-background) (if (memq 'transparent canvas-style) #f diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 4ee321b1..ebed2371 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -20,6 +20,9 @@ (define-gtk gtk_drawing_area_new (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) +(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) + (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) @@ -37,6 +40,12 @@ (define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)) (define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)) +(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) + +(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) + #:c-id g_object_set) + (define-cstruct _GdkColor ([pixel _uint32] [red _uint16] [green _uint16] @@ -49,9 +58,30 @@ (define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void)) (define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void)) +;; We rely some on the implementation of GtkComboBoxEntry to replace +;; the drawing routine. +(define-cstruct _GList ([data _pointer])) +(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null)) +(define-gdk gdk_window_hide (_fun _pointer -> _void)) +(define (get-subwindow gtk) + (let* ([win (g_object_get_window gtk)] + [subs (gdk_window_get_children win)]) + (if subs + (GList-data subs) + win))) + +(define-signal-handler connect-changed "changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (send wx combo-maybe-clicked)))) + +(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) + (define (handle-expose gtk event) (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) + (let ([gc (send wx get-canvas-background-for-clearing)]) (when gc (gdk_draw_rectangle (g_object_get_window gtk) gc #t 0 0 32000 32000))) @@ -74,6 +104,7 @@ (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)) (define canvas% (class (client-size-mixin window%) @@ -86,36 +117,45 @@ (inherit get-gtk set-size get-size get-client-size on-size register-as-child get-top-win) - (define client-gtk (gtk_drawing_area_new)) - (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) - (if (or (memq 'hscroll style) - (memq 'vscroll style)) - (let ([hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] - [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) - (let ([h (gtk_hbox_new #f 0)] - [v (gtk_vbox_new #f 0)] - [v2 (gtk_vbox_new #f 0)] - [h2 (gtk_vbox_new #f 0)] - [hscroll (gtk_hscrollbar_new hadj)] - [vscroll (gtk_vscrollbar_new vadj)] - [resize-box (gtk_drawing_area_new)]) - (gtk_box_pack_start h v #t #t 0) - (gtk_box_pack_start v client-gtk #t #t 0) - (gtk_box_pack_start h v2 #f #f 0) - (gtk_box_pack_start v2 vscroll #t #t 0) - (gtk_box_pack_start v h2 #f #f 0) - (gtk_box_pack_start h2 hscroll #t #t 0) - (gtk_box_pack_start v2 resize-box #f #f 0) - (gtk_widget_show hscroll) - (gtk_widget_show vscroll) - (gtk_widget_show h) - (gtk_widget_show v) - (gtk_widget_show v2) - (gtk_widget_show h2) - (gtk_widget_show resize-box) - (gtk_widget_show client-gtk) - (values h hadj vadj h2 v2 resize-box))) - (values client-gtk #f #f #f #f #f))) + (define is-combo? (memq 'combo style)) + + (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) + (cond + [(or (memq 'hscroll style) + (memq 'vscroll style)) + (let* ([client-gtk (gtk_drawing_area_new)] + [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)] + [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]) + (let ([h (gtk_hbox_new #f 0)] + [v (gtk_vbox_new #f 0)] + [v2 (gtk_vbox_new #f 0)] + [h2 (gtk_vbox_new #f 0)] + [hscroll (gtk_hscrollbar_new hadj)] + [vscroll (gtk_vscrollbar_new vadj)] + [resize-box (gtk_drawing_area_new)]) + (gtk_box_pack_start h v #t #t 0) + (gtk_box_pack_start v client-gtk #t #t 0) + (gtk_box_pack_start h v2 #f #f 0) + (gtk_box_pack_start v2 vscroll #t #t 0) + (gtk_box_pack_start v h2 #f #f 0) + (gtk_box_pack_start h2 hscroll #t #t 0) + (gtk_box_pack_start v2 resize-box #f #f 0) + (gtk_widget_show hscroll) + (gtk_widget_show vscroll) + (gtk_widget_show h) + (gtk_widget_show v) + (gtk_widget_show v2) + (gtk_widget_show h2) + (gtk_widget_show resize-box) + (gtk_widget_show client-gtk) + (values client-gtk h hadj vadj h2 v2 resize-box)))] + [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))] + [else + (let ([client-gtk (gtk_drawing_area_new)]) + (values client-gtk client-gtk #f #f #f #f #f))])) (super-new [parent parent] [gtk gtk] @@ -123,7 +163,9 @@ [no-show? (memq 'deleted style)] [extra-gtks (if (eq? client-gtk gtk) null - (list client-gtk hscroll-adj vscroll-adj))]) + (if hscroll-adj + (list client-gtk hscroll-adj vscroll-adj) + (list client-gtk)))]) (set-size x y w h) @@ -134,7 +176,11 @@ [h (box 0)]) (get-client-size w h) (values (unbox w) (unbox h))))] - [window-lock (send (get-top-win) get-dc-lock)])) + [window-lock (send (get-top-win) get-dc-lock)] + [get-window (lambda (client-gtk) + (if is-combo? + (get-subwindow client-gtk) + (g_object_get_window client-gtk)))])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) @@ -146,7 +192,7 @@ (GtkRequisition-height r) (GtkRequisition-height r)))) - (g_signal_connect client-gtk "expose_event" handle_expose) + (g_signal_connect client-gtk "expose-event" handle_expose) (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK @@ -294,6 +340,19 @@ gc) #f))) + (when is-combo? + (connect-changed client-gtk)) + + (define/public (append-combo-item str) + (gtk_combo_box_append_text gtk str)) + + (define/public (combo-maybe-clicked) + (let ([i (gtk_combo_box_get_active gtk)]) + (when (i . > . -1) + (gtk_combo_box_set_active gtk -1) + (queue-window-event this (lambda () (on-combo-select i)))))) + (define/public (on-combo-select i) (void)) + (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index a421218e..bb31608e 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -21,14 +21,15 @@ (class default-dc-backend% (init-field gtk get-client-size - window-lock) + window-lock + [get-window g_object_get_window]) (inherit reset-cr) (define c #f) (define/override (get-cr) (or c - (let ([w (g_object_get_window gtk)]) + (let ([w (get-window gtk)]) (and w (begin ;; Under Windows, creating a Cairo context within @@ -36,7 +37,7 @@ ;; within the same frame. So we use a lock to ;; serialize drawing to different contexts. (when window-lock (semaphore-wait window-lock)) - (set! c (gdk_cairo_create w)) + (set! c (gdk_cairo_create w)) (reset-cr c) c))))) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 49305bcf..20d9797d 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -6,6 +6,7 @@ _GtkWidget _GtkWindow _gpointer _GdkEventExpose + _GType _fnpointer _gboolean @@ -20,6 +21,8 @@ _GdkEventCrossing _GdkEventCrossing-pointer (struct-out GdkEventCrossing)) +(define _GType _long) + (define _GdkWindow (_cpointer/null 'GdkWindow)) (define _GtkWidget (_cpointer 'GtkWidget)) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index d3c6946c..a8e27d4a 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -19,6 +19,8 @@ g_object_get_data g_signal_connect + g_object_new + (rename-out [g_object_get g_object_get_window]) get-gtk-object-flags @@ -87,6 +89,8 @@ [w : (_ptr o _GdkWindow)] (_pointer = #f) -> _void -> w)) +(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget)) + ;; This seems dangerous, since the shape of GtkObject is not ;; documented. But it seems to be the only way to get and set ;; flags. diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 629b070c..7c92b581 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -162,7 +162,11 @@ (private-field [l (and label (make-object wx-message% #f proxy p label -1 -1 null font))] - [c (make-object wx-text-editor-canvas% #f proxy this p + [c (make-object (class wx-text-editor-canvas% + (define/override (on-combo-select i) + ((list-ref callbacks (- (length callbacks) i 1)))) + (super-new)) + #f proxy this p (append '(control-border) (if (memq 'combo style) @@ -172,7 +176,13 @@ (if (memq 'hscroll style) null '(hide-hscroll)) - '(hide-vscroll hide-hscroll))))]) + '(hide-vscroll hide-hscroll))))] + [callbacks null]) + (public + [append-combo-item (lambda (s cb) + (and (send c append-combo-item s) + (set! callbacks (cons cb callbacks)) + #t))]) (sequence (send c skip-subwindow-events? #t) (when l