From 30d1312fab6b8aa2e47b5faaf6ab9100164cec93 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Dec 2010 10:40:11 -0700 Subject: [PATCH] cocoa and gtk: make combo-field% `on-popup' work better original commit: c9e778c54137b1fe1468e9ef46a242245572e9e1 --- collects/mred/private/wx/cocoa/canvas.rkt | 11 +++++----- collects/mred/private/wx/gtk/canvas.rkt | 18 ++++++++++++---- collects/mred/private/wxtextfield.rkt | 25 ++++++++++++++++++++++- 3 files changed, 44 insertions(+), 10 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7e3d0cdb..7c75add2 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -382,6 +382,7 @@ (define/override (get-client-size xb yb) (super get-client-size xb yb) (when is-combo? + (set-box! xb (max 0 (- (unbox xb) 22))) (set-box! yb (max 0 (- (unbox yb) 5))))) (define/override (maybe-register-as-child parent on?) @@ -627,6 +628,8 @@ (tellv content-cocoa addItemWithObjectValue: #:type _NSString str) #t) (define/public (on-combo-select i) (void)) + (define/public (popup-combo) + (tellv (tell content-cocoa cell) popUp: #f)) (define clear-bg? (and (not (memq 'transparent canvas-style)) (not (memq 'no-autoclear canvas-style)))) @@ -718,7 +721,7 @@ (let ([xb (box 0)] [yb (box 0)]) (get-client-size xb yb) - ((send e get-x) . > . (- (unbox xb) 22)))) + ((send e get-x) . > . (unbox xb)))) (define/public (on-popup) (void)) @@ -764,12 +767,10 @@ (void)) (define/public (get-backing-size xb yb) - (get-client-size xb yb) - (when is-combo? - (set-box! xb (- (unbox xb) 22)))) + (get-client-size xb yb)) (define/override (get-cursor-width-delta) - (if is-combo? 22 0)) + 0) (define/public (is-flipped?) (tell #:type _BOOL (get-cocoa-content) isFlipped)) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index eb19b784..3fc128e3 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -41,6 +41,7 @@ (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)) (define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) @@ -344,10 +345,19 @@ (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) (define/override (internal-pre-on-event gtk e) - (when (and (ptr-equal? gtk combo-button-gtk) - (send e button-down?)) - (on-popup)) - #f) + (if (and (ptr-equal? gtk combo-button-gtk) + (send e button-down?)) + (begin + (on-popup) + #t) + #f)) + (define/public (popup-combo) + ;; Unfortunately, the user has to hold the mouse + ;; button down when popping up the menu this way, + ;; whereas the default handler (that we subvert in + ;; `internal-pre-on-event') keeps the menu open if + ;; the user release the mouse button right away. + (gtk_combo_box_popup gtk)) (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index 6f4c7f39..4ff6f54b 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -221,6 +221,7 @@ (private-field [l (and label (make-object wx-message% #f proxy p label -1 -1 null font))] + [combo-callback #f] [c (make-object (class wx-text-editor-canvas% (define/override (on-combo-select i) (let ([len (length callbacks)]) @@ -239,8 +240,30 @@ '(hide-hscroll)) '(hide-vscroll hide-hscroll))))] [callbacks null]) + (override + [pre-on-event (lambda (w e) + (or (super pre-on-event w e) + (and combo-callback + (eq? w c) + (send e button-down?) + (let ([w (box 0)] + [h (box 0)]) + (send c get-client-size w h) + (not (and (<= 0 (send e get-x) (unbox w)) + (<= 0 (send e get-y) (unbox h))))) + (begin + (do-popup-callback) + #t))))]) + (private + [do-popup-callback (lambda () + (wx:queue-callback (lambda () + (combo-callback) + (send c popup-combo)) + wx:middle-queue-key))]) (public - [set-on-popup (lambda (proc) (send c set-on-popup proc))] + [set-on-popup (lambda (proc) + (set! combo-callback proc) + (send c set-on-popup (lambda () (do-popup-callback))))] [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))] [append-combo-item (lambda (s cb) (and (send c append-combo-item s)