From 992d32134c9696bc24c0227f7c2d7c7fec3a03dc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 19:39:43 -0600 Subject: [PATCH] enforce modality; more on-subwindow- callbacks; Cocoa font tweaks original commit: e9e180847a72ba91ea817fc3b5fc1a457e676747 --- collects/mred/private/wx/cocoa/button.rkt | 2 +- collects/mred/private/wx/cocoa/choice.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 61 +++++++++++++------ .../mred/private/wx/cocoa/group-panel.rkt | 6 +- collects/mred/private/wx/cocoa/list-box.rkt | 1 + collects/mred/private/wx/cocoa/message.rkt | 21 +++++-- collects/mred/private/wx/cocoa/radio-box.rkt | 2 +- collects/mred/private/wx/cocoa/slider.rkt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 7 +++ collects/mred/private/wx/common/queue.rkt | 13 ++++ collects/mred/private/wx/gtk/choice.rkt | 2 + collects/mred/private/wx/gtk/dialog.rkt | 17 ++++++ collects/mred/private/wx/gtk/frame.rkt | 21 ++++--- collects/mred/private/wx/gtk/menu-bar.rkt | 17 ++++++ collects/mred/private/wx/gtk/tab-panel.rkt | 2 + collects/mred/private/wx/gtk/window.rkt | 8 ++- 17 files changed, 146 insertions(+), 39 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index f6dd2c72..5cf3a558 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -24,7 +24,7 @@ (define MIN-BUTTON-WIDTH 72) (define-objc-class MyButton NSButton - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index 98b1f869..e94fc82b 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -19,7 +19,7 @@ (import-class NSPopUpButton) (define-objc-class MyPopUpButton NSPopUpButton - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index d21ed049..81b5f05b 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -27,16 +27,20 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) +(define dialog-level-counter 0) + (define-objc-mixin (MyWindowMethods Superclass) [wx] [-a _scheme (getEventspace) (send wx get-eventspace)] - [-a _BOOL (canBecomeKeyWindow) #t] + [-a _BOOL (canBecomeKeyWindow) + (not (other-modal? wx))] [-a _BOOL (canBecomeMainWindow) #t] [-a _BOOL (windowShouldClose: [_id win]) (queue-window-event wx (lambda () - (when (send wx on-close) - (send wx direct-show #f)))) + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f))))) #f] [-a _void (windowDidResize: [_id notification]) (when wx @@ -149,7 +153,21 @@ (tell NSGraphicsContext graphicsContextWithWindow: cocoa))) (define is-a-dialog? is-dialog?) + (define dialog-level 0) (define/public (frame-is-dialog?) is-a-dialog?) + (define/public (frame-relative-dialog-status win) + ;; called in event-pump thread + (cond + [is-a-dialog? (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))] + [else #f])) + + (define/override (get-dialog-level) + ;; called in event-pump thread + dialog-level) (define/public (clean-up) ;; When a window is resized, then any drawing that is in flight @@ -171,25 +189,32 @@ (set! front #f) (send empty-mb install)) (if on? - (if (and is-a-dialog? - (let ([p (get-parent)]) - (and p - (not (send p get-sheet))))) - (let ([p (get-parent)]) - (send p set-sheet this) - (tell (tell NSApplication sharedApplication) - beginSheet: cocoa - modalForWindow: (send p get-cocoa) - modalDelegate: #f - didEndSelector: #:type _SEL #f - contextInfo: #f)) - (tellv cocoa makeKeyAndOrderFront: #f)) (begin (when is-a-dialog? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (if (and is-a-dialog? + (let ([p (get-parent)]) + (and p + (not (send p get-sheet))))) + (let ([p (get-parent)]) + (send p set-sheet this) + (tell (tell NSApplication sharedApplication) + beginSheet: cocoa + modalForWindow: (send p get-cocoa) + modalDelegate: #f + didEndSelector: #:type _SEL #f + contextInfo: #f)) + (tellv cocoa makeKeyAndOrderFront: #f))) + (begin + (when is-a-dialog? + (set! dialog-level 0) (let ([p (get-parent)]) (when (and p (eq? this (send p get-sheet))) - (send p set-sheet #f)))) + (send p set-sheet #f) + (tell (tell NSApplication sharedApplication) + endSheet: cocoa)))) (tellv cocoa orderOut: #f) (let ([next (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] @@ -316,7 +341,7 @@ (define/public (set-modified on?) ;; Use standardWindowButton: ... (void)) - + (define/public (create-status-line) (void)) (define/public (set-status-text s) (void)) (def/public-unimplemented status-line-exists?) diff --git a/collects/mred/private/wx/cocoa/group-panel.rkt b/collects/mred/private/wx/cocoa/group-panel.rkt index ef1c4200..73588a0a 100644 --- a/collects/mred/private/wx/cocoa/group-panel.rkt +++ b/collects/mred/private/wx/cocoa/group-panel.rkt @@ -14,6 +14,10 @@ (import-class NSBox) +(define-objc-class MyBox NSBox + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + (defclass group-panel% (panel-mixin window%) (init parent x y w h @@ -24,7 +28,7 @@ (super-new [parent parent] [cocoa (let ([cocoa (as-objc-allocation - (tell (tell NSBox alloc) init))]) + (tell (tell MyBox alloc) init))]) (when label (tellv cocoa setTitle: #:type _NSString label) (tellv cocoa sizeToFit)) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index c02bc1c0..7fda6f6e 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -22,6 +22,7 @@ (import-protocol NSTableViewDataSource) (define-objc-class MyTableView NSTableView + #:mixins (FocusResponder KeyMouseResponder) [wx] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (tell (tell NSCell alloc) initTextCell: #:type _NSString (send wx get-row row))] diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 6a09103f..68d5cc44 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -4,10 +4,11 @@ ffi/objc racket/draw/bitmap "../../syntax.rkt" - "item.rkt" - "utils.rkt" - "types.rkt" - "image.rkt") + "window.rkt" + "item.rkt" + "utils.rkt" + "types.rkt" + "image.rkt") (unsafe!) (objc-unsafe!) @@ -30,6 +31,14 @@ #:type _NSString "NSApplicationPath"))) +(define-objc-class MyTextField NSTextField + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + +(define-objc-class MyImageView NSImageView + #:mixins (FocusResponder KeyMouseResponder) + [wx]) + (defclass message% item% (init parent label x y @@ -59,9 +68,9 @@ [cocoa (if (string? label) (as-objc-allocation - (tell (tell NSTextField alloc) init)) + (tell (tell MyTextField alloc) init)) (as-objc-allocation - (tell (tell NSImageView alloc) init)))]) + (tell (tell MyImageView alloc) init)))]) (cond [(string? label) (init-font cocoa font) diff --git a/collects/mred/private/wx/cocoa/radio-box.rkt b/collects/mred/private/wx/cocoa/radio-box.rkt index 6edf6fd0..211410e6 100644 --- a/collects/mred/private/wx/cocoa/radio-box.rkt +++ b/collects/mred/private/wx/cocoa/radio-box.rkt @@ -24,7 +24,7 @@ (define NSListModeMatrix 2) (define-objc-class MyMatrix NSMatrix - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (clicked: [_id sender]) (queue-window-event wx (lambda () (send wx clicked))))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 679f42bd..c0a8e780 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -22,7 +22,7 @@ (import-class NSSlider) (define-objc-class MySlider NSSlider - #:mixins (FocusResponder) + #:mixins (FocusResponder KeyMouseResponder) [wx] (-a _void (changed: [_id sender]) (queue-window-event wx (lambda () (send wx changed))) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 3548c163..175e4d40 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -18,6 +18,7 @@ (import-protocol NSTabViewDelegate) (define-objc-class MyTabView NSTabView + #:mixins (FocusResponder KeyMouseResponder) #:protocols (NSTabViewDelegate) [wx] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 7cd2f75a..81d09aac 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -8,6 +8,7 @@ "types.rkt" "keycode.rkt" "../common/event.rkt" + "../common/queue.rkt" "../../syntax.rkt" "../common/freeze.rkt") (unsafe!) @@ -180,6 +181,10 @@ (define/public (get-cocoa-window) (send parent get-cocoa-window)) (define/public (get-wx-window) (send parent get-wx-window)) + (define/public (get-dialog-level) + ;; called in event-pump thread + (send parent get-dialog-level)) + (define/public (make-graphics-context) (and parent (send parent make-graphics-context))) @@ -294,11 +299,13 @@ (define/public (dispatch-on-char e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-event this e) #t] [just-pre? #f] [else (when enabled? (on-event e)) #t])) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index d6b4309b..c50a3371 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe racket/draw/utils ffi/unsafe/atomic + racket/class "rbtree.rkt" "../../lock.rkt" "handlers.rkt") @@ -35,6 +36,7 @@ register-frame-shown get-top-level-windows + other-modal? queue-quit-event) @@ -329,9 +331,20 @@ 'frame-remove))) (define (get-top-level-windows) + ;; called in event-pump thread (hash-map (eventspace-frames-hash (current-eventspace)) (lambda (k v) k))) +(define (other-modal? win) + ;; called in event-pump thread + (let loop ([frames (get-top-level-windows)]) + (and (pair? frames) + (let ([status (send (car frames) frame-relative-dialog-status win)]) + (case status + [(#f) (loop (cdr frames))] + [(same) #f] + [(other) #t]))))) + (define (queue-quit-event) ;; called in event-pump thread (queue-event main-eventspace (application-quit-handler) 'med)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ccd5c549..ff7c532c 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -62,6 +62,8 @@ [callback cb] [no-show? (memq 'deleted style)]) + (connect-key-and-mouse button-gtk) + (gtk_combo_box_set_active gtk 0) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/dialog.rkt b/collects/mred/private/wx/gtk/dialog.rkt index eee9934b..5cf001f8 100644 --- a/collects/mred/private/wx/gtk/dialog.rkt +++ b/collects/mred/private/wx/gtk/dialog.rkt @@ -18,6 +18,8 @@ (define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) +(define dialog-level-counter 0) + (defclass dialog% frame% (inherit get-gtk get-parent) @@ -32,7 +34,22 @@ (when p (gtk_window_set_transient_for (get-gtk) (send p get-gtk)))) + (define dialog-level 0) + (define/override (get-dialog-level) dialog-level) + + (define/override (frame-relative-dialog-status win) + (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))) + (define/override (direct-show on?) + (when on? + (set! dialog-level-counter (add1 dialog-level-counter)) + (set! dialog-level dialog-level-counter)) + (unless on? + (set! dialog-level 0)) (unless on? (when close-sema (semaphore-post close-sema) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index 06e8ee90..ec99970b 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -52,14 +52,14 @@ (define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void)) -(define (handle-delete gtk) - (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () - (when (send wx on-close) - (send wx direct-show #f)))))) -(define handle_delete - (function-ptr handle-delete - (_fun #:atomic? #t _GtkWidget -> _gboolean))) +(define-signal-handler connect-delete "delete-event" + (_fun _GtkWidget -> _gboolean) + (lambda (gtk) + (let ([wx (gtk->wx gtk)]) + (queue-window-event wx (lambda () + (unless (other-modal? wx) + (when (send wx on-close) + (send wx direct-show #f)))))))) (define-signal-handler connect-configure "configure-event" (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) @@ -121,7 +121,7 @@ (set-size x y w h) - (g_signal_connect gtk "delete_event" handle_delete) + (connect-delete gtk) (connect-configure gtk) (when label @@ -159,6 +159,9 @@ (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) (define/public (get-dc-lock) dc-lock) + (define/override (get-dialog-level) 0) + (define/public (frame-relative-dialog-status win) #f) + (define/override (center dir wrt) (let ([w-box (box 0)] [h-box (box 0)] diff --git a/collects/mred/private/wx/gtk/menu-bar.rkt b/collects/mred/private/wx/gtk/menu-bar.rkt index 0f371ad8..3e086852 100644 --- a/collects/mred/private/wx/gtk/menu-bar.rkt +++ b/collects/mred/private/wx/gtk/menu-bar.rkt @@ -3,6 +3,7 @@ scheme/foreign "../../syntax.rkt" "../common/freeze.rkt" + "../common/queue.rkt" "widget.rkt" "utils.rkt" "types.rkt") @@ -49,7 +50,17 @@ (define/public (get-top-window) (send parent get-top-window)) (super-new))) +(define-signal-handler connect-menu-key-press "key-press-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (other-modal? wx)))) +(define-signal-handler connect-menu-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (other-modal? wx)))) (defclass menu-bar% widget% (define menus null) @@ -59,12 +70,18 @@ (define/public (get-gtk) gtk) + (connect-menu-key-press gtk) + (connect-menu-button-press gtk) + (define top-wx #f) (define/public (set-top-window top) (set! top-wx top)) (define/public (get-top-window) top-wx) + (define/public (get-dialog-level) + (send top-wx get-dialog-level)) + (define/public (set-label-top pos str) (let ([l (list-ref menus pos)]) (let ([item-gtk (car l)]) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 5ff4a204..ab06e85d 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -86,6 +86,8 @@ [extra-gtks (list client-gtk)] [no-show? (memq 'deleted style)]) + (connect-key-and-mouse gtk) + (set-auto-size) (define callback void) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 42782028..0fb3fab9 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -5,6 +5,7 @@ "../../syntax.rkt" "../common/event.rkt" "../common/freeze.rkt" + "../common/queue.rkt" "keycode.rkt" "queue.rkt" "utils.rkt" @@ -107,7 +108,8 @@ (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (lambda (gtk event) (unless (gtk_widget_is_focus gtk) - (gtk_widget_grab_focus gtk)) + (unless (other-modal? (gtk->wx gtk)) + (gtk_widget_grab_focus gtk))) (do-button-event gtk event #f #f))) (define-signal-handler connect-button-release "button-release-event" @@ -335,6 +337,8 @@ (define/public (get-top-win) (send parent get-top-win)) + (define/public (get-dialog-level) (send parent get-dialog-level)) + (define/public (get-size xb yb) (set-box! xb save-w) (set-box! yb save-h)) @@ -365,11 +369,13 @@ (define/public (handles-events?) #f) (define/public (dispatch-on-char e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-char this e) #t] [just-pre? #f] [else (when enabled? (on-char e)) #t])) (define/public (dispatch-on-event e just-pre?) (cond + [(other-modal? this) #t] [(call-pre-on-event this e) #t] [just-pre? #f] [else (when enabled? (on-event e)) #t]))