From 4535f5d8cc0fe4d0c3c360d7527980b1c3b7e39a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 30 Sep 2011 12:17:46 -0600 Subject: [PATCH] fix keyboard navigation (all platforms) Also, fix `set-selection' in `list-box%' to not invoke the tab panel's callback function (cocoa & gtk). --- collects/mred/private/helper.rkt | 23 ++++++++-------- collects/mred/private/wx/cocoa/radio-box.rkt | 12 ++++++-- collects/mred/private/wx/cocoa/tab-panel.rkt | 29 ++++++++++++++++++-- collects/mred/private/wx/cocoa/window.rkt | 3 +- collects/mred/private/wx/gtk/message.rkt | 2 ++ collects/mred/private/wx/gtk/panel.rkt | 2 ++ collects/mred/private/wx/gtk/radio-box.rkt | 2 +- collects/mred/private/wx/gtk/tab-panel.rkt | 24 ++++++++++++++-- collects/mred/private/wx/win32/tab-panel.rkt | 9 ++++++ collects/mred/private/wxpanel.rkt | 25 +++++++++++++---- collects/mred/private/wxtop.rkt | 8 ++++-- 11 files changed, 111 insertions(+), 28 deletions(-) diff --git a/collects/mred/private/helper.rkt b/collects/mred/private/helper.rkt index 59466f1527..dd10a7823f 100644 --- a/collects/mred/private/helper.rkt +++ b/collects/mred/private/helper.rkt @@ -286,17 +286,18 @@ append (map (lambda (i) - (cond - [(send i has-tabbing-children?) - (if (send i is-shown-to-root?) - (container->children i except must-focus?) - null)] - [(or (eq? i except) - (and must-focus? (not (send i gets-focus?))) - (not (send i is-enabled-to-root?)) - (not (send i is-shown-to-root?))) - null] - [else (list i)])) + (append + (if (and (send i has-tabbing-children?) + (send i is-shown-to-root?)) + (container->children i except must-focus?) + null) + (cond + [(or (eq? i except) + (and must-focus? (not (send i gets-focus?))) + (not (send i is-enabled-to-root?)) + (not (send i is-shown-to-root?))) + null] + [else (list i)]))) (send f get-children)))) (define (filter-overlapping l) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index d52ef15514..604ca1ce47 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -115,8 +115,16 @@ (define/public (button-focus i) (if (= i -1) - 0 - (set-focus))) + (if horiz? + (tell #:type _NSInteger (get-cocoa) selectedColumn) + (tell #:type _NSInteger (get-cocoa) selectedRow)) + (let ([which (get-selection)]) + (set-focus) + (tellv (get-cocoa) + selectCellAtRow: #:type _NSInteger (if horiz? 0 i) + column: #:type _NSInteger (if horiz? i 0)) + (unless (equal? which (get-selection)) + (queue-window-event this (lambda () (clicked))))))) (define/private (get-button i) (tell (get-cocoa) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 5b5b220597..b47d1874d7 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -11,6 +11,7 @@ "queue.rkt" "../common/event.rkt" "../common/procs.rkt" + "../../lock.rkt" (for-syntax racket/base)) (provide @@ -44,7 +45,9 @@ #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) - (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) + (let ([wx (->wx wxb)]) + (when (and wx (send wx callbacks-enabled?)) + (queue-window*-event wxb (lambda (wx) (send wx do-callback))))))) (define-objc-class MyPSMTabBarControl PSMTabBarControl #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) @@ -125,9 +128,17 @@ (define/public (set-label i str) (tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str))) + + (define callbacks-ok? #t) + (define/public (callbacks-enabled?) callbacks-ok?) - (define/public (set-selection i) + (define/private (direct-set-selection i) (tellv tabv-cocoa selectTabViewItem: (list-ref item-cocoas i))) + (define/public (set-selection i) + (atomically + (set! callbacks-ok? #f) + (direct-set-selection i) + (set! callbacks-ok? #t))) (define/public (get-selection) (item->index (tell tabv-cocoa selectedTabViewItem))) @@ -183,6 +194,20 @@ (when control-cocoa (tellv control-cocoa setEnabled: #:type _BOOL on?)))) + (define/override (gets-focus?) + (and (not control-cocoa) + (tell #:type _BOOL tabv-cocoa canBecomeKeyView))) + (define/override (get-cocoa-focus) + (if control-cocoa + content-cocoa + tabv-cocoa)) + + (define/public (number) (length item-cocoas)) + (define/public (button-focus n) + (if (= n -1) + (get-selection) + (direct-set-selection n))) + (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 56ea7fbd48..b2d2488116 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -482,6 +482,7 @@ (define/public (get-cocoa) cocoa) (define/public (get-cocoa-content) cocoa) + (define/public (get-cocoa-focus) (get-cocoa-content)) (define/public (get-cocoa-cursor-content) (get-cocoa-content)) (define/public (get-cocoa-window) (send parent get-cocoa-window)) (define/public (get-wx-window) (send parent get-wx-window)) @@ -674,7 +675,7 @@ (is-enabled-to-root?)) (let ([w (tell cocoa window)]) (when w - (tellv w makeFirstResponder: (get-cocoa-content)))))) + (tellv w makeFirstResponder: (get-cocoa-focus)))))) (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index 7b72085e05..549fb4b249 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -77,4 +77,6 @@ (set-auto-size) #t) + (define/override (gets-focus?) #f) + (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 8fe82e7161..15600daa58 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -128,6 +128,8 @@ (define/override (get-client-gtk) client-gtk) + (define/override (gets-focus?) #f) + (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk)] diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt index 1557374e43..f610cc7eef 100644 --- a/collects/mred/private/wx/gtk/radio-box.rkt +++ b/collects/mred/private/wx/gtk/radio-box.rkt @@ -103,7 +103,7 @@ 0) (gtk_widget_grab_focus (list-ref radio-gtks i)))) (define/override (set-focus) - (button-focus (max 0 (set-selection)))) + (button-focus (max 0 (get-selection)))) (define/public (set-selection i) (atomically (set! no-clicked? #t) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 0e622a24c8..0ab28a3948 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -9,6 +9,7 @@ "types.rkt" "widget.rkt" "message.rkt" + "../../lock.rkt" "../common/event.rkt") (provide @@ -21,6 +22,7 @@ (define-gtk gtk_notebook_set_scrollable (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_notebook_get_tab_label (_fun _GtkWidget _GtkWidget -> _GtkWidget)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) @@ -110,11 +112,14 @@ (select-bin bin-gtk) (gtk_widget_unref client-gtk)) + (define callback-ok? #t) + (define/public (page-changed i) ; range check works around spurious callbacks: (when (< -1 i (length pages)) (swap-in (page-bin-gtk (list-ref pages i))) - (queue-window-event this (lambda () (do-callback))))) + (when callback-ok? + (queue-window-event this (lambda () (do-callback)))))) (connect-changed gtk) (define/override (get-client-gtk) client-gtk) @@ -159,7 +164,22 @@ (gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i)) (mnemonic-string str))) - (define/public (set-selection i) + (define/public (number) (length pages)) + (define/public (button-focus n) + (if (= n -1) + (get-selection) + (direct-set-selection n))) + + (define/override (gets-focus?) #t) + (define/override (set-focus) + (gtk_widget_grab_focus gtk)) + + (define/private (direct-set-selection i) (gtk_notebook_set_current_page gtk i)) + (define/public (set-selection i) + (atomically + (set! callback-ok? #f) + (direct-set-selection i) + (set! callback-ok? #t))) (define/public (get-selection) (gtk_notebook_get_current_page gtk)))) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index a017ef9e2c..d89097366a 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -25,6 +25,8 @@ (define TCM_GETITEMCOUNT (+ TCM_FIRST 4)) (define TCM_DELETEITEM (+ TCM_FIRST 8)) (define TCM_DELETEALLITEMS (+ TCM_FIRST 9)) +(define TCM_GETCURFOCUS (+ TCM_FIRST 47)) +(define TCM_SETCURFOCUS (+ TCM_FIRST 48)) (define-cstruct _TCITEMW ([mask _UINT] @@ -169,6 +171,13 @@ (let ([sel (max 0 (min (length choices) sel))]) (set-selection sel)))) + (define/override (gets-focus?) #t) + + (define/public (button-focus i) + (if (= i -1) + (SendMessageW hwnd TCM_GETCURFOCUS 0 0) + (SendMessageW hwnd TCM_SETCURFOCUS i 0))) + (define/public (set-callback cb) (set! callback cb)))) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index fab0c7ba26..73f9f93311 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -37,6 +37,7 @@ [on-set-focus (lambda () (void))] [on-kill-focus (lambda () (void))] [set-focus (lambda () (void))] + [gets-focus? (lambda () #f)] [enable (lambda () (void))] [show (lambda (on?) (void))] [is-shown? (lambda () #f)] @@ -110,9 +111,11 @@ [set-focus ; dispatch focus to a child panel (lambda () - (if (null? children) - (super-set-focus) - (send (car children) set-focus)))] + (if (focus-on-self?) + (super-set-focus) + (if (null? children) + (super-set-focus) + (send (car children) set-focus))))] [ext-dx (lambda () (if hidden-child tab-h-border @@ -131,6 +134,7 @@ (public [need-move-children (lambda () (set! move-children? #t))] + [focus-on-self? (lambda () #f)] [get-children (lambda () children)] [get-hidden-child (lambda () hidden-child)] @@ -806,19 +810,28 @@ ;; "horizontal" and "vertical." (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) + (define (wx-make-tab% %) + (class % + (inherit gets-focus?) + (super-new) + (define/override (tabbing-position x y w h) + ;; claim that the panel is short: + (list this x y w 16)) + (define/override (focus-on-self?) (gets-focus?)))) + (define wx-panel% (wx-make-panel% wx:panel%)) (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) (define wx-canvas-panel% (wx-make-panel% wx:canvas-panel%)) - (define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) + (define wx-tab-panel% (wx-make-tab% (wx-make-panel% wx:tab-panel%))) (define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) (define wx-linear-canvas-panel% (wx-make-linear-panel% wx-canvas-panel%)) (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%)) - (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) + (define wx-linear-tab-panel% (wx-make-tab% (wx-make-linear-panel% wx-tab-panel%))) (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-horizontal-panel% (wx-make-horizontal-panel% wx-linear-panel%)) (define wx-vertical-panel% (wx-make-vertical-panel% wx-linear-panel%)) - (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) + (define wx-vertical-tab-panel% (wx-make-tab% (wx-make-vertical-panel% wx-linear-tab-panel%))) (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%)) (define wx-horizontal-canvas-panel% (wx-make-horizontal-panel% wx-linear-canvas-panel%)) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 252346f6f6..164aca0f2a 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -496,12 +496,14 @@ (memq code '(right down)))] [normal-move (lambda () - (let* ([o (if (or (is-a? o wx:canvas%) (is-a? o wx:item%)) + (let* ([o (if (or (is-a? o wx:canvas%) + (is-a? o wx:item%) + (is-a? o wx:tab-panel%)) (if (is-a? o wx-group-box<%>) #f o) #f)] - [candidates + [candidates (map object->position (container->children panel o #t))] [dests (filter-overlapping candidates)] [pos (if o (object->position o) (list 'x 0 0 1 1))] @@ -528,7 +530,7 @@ (as-exit (lambda () (send o on-tab-in))))))))))]) (if (and (not (eqv? code #\tab)) (or (is-a? o wx:radio-box%) - (is-a? o wx-tab-group<%>))) + (is-a? o wx:tab-panel%))) (let ([n (send o number)] [s (send o button-focus -1)] [v-move? (memq code '(up down))]