cocoa: event-dispatch repairs, especially when no frame is shown
Relevant to PR 11672
This commit is contained in:
Matthew Flatt
parent
dc2bdfcea3
commit
b485d375b0
|
|
@ -24,6 +24,8 @@
|
|||
(protect menu-parent-only
|
||||
menu-or-bar-parent))
|
||||
|
||||
(define root-menu-frame-used? #f)
|
||||
|
||||
;; Most of the work is in the item. Anything that appears in a menubar or
|
||||
;; menu has an item. Submenus are created as instances of menu%, but
|
||||
;; menu% has a get-item method for manipulating the menu w.r.t. the parent
|
||||
|
|
@ -426,17 +428,13 @@
|
|||
(private-field
|
||||
[callback demand-callback]
|
||||
[prnt (if (eq? parent 'root)
|
||||
(let ([f (make-object (class frame%
|
||||
(define/override (on-exit)
|
||||
(exit))
|
||||
(super-make-object "Root")))])
|
||||
(begin
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(when root-menu-frame
|
||||
(when root-menu-frame-used?
|
||||
(raise-mismatch-error (constructor-name 'menu-bar) "already has a menu bar: " parent))
|
||||
(send (mred->wx f) designate-root-frame)
|
||||
(set-root-menu-frame! f)))
|
||||
f)
|
||||
(set! root-menu-frame-used? #t)))
|
||||
root-menu-frame)
|
||||
parent)]
|
||||
[wx #f]
|
||||
[wx-parent #f]
|
||||
|
|
|
|||
|
|
@ -14,13 +14,13 @@
|
|||
"wxpanel.ss"
|
||||
"wxitem.ss"
|
||||
"mrwindow.ss"
|
||||
"mrcontainer.ss")
|
||||
"mrcontainer.ss"
|
||||
"app.ss")
|
||||
|
||||
(provide top-level-window<%>
|
||||
frame%
|
||||
dialog%
|
||||
(protect root-menu-frame
|
||||
set-root-menu-frame!)
|
||||
(protect root-menu-frame)
|
||||
get-top-level-windows
|
||||
get-top-level-focus-window
|
||||
get-top-level-edit-target-window
|
||||
|
|
@ -267,11 +267,6 @@
|
|||
(check-container-ready cwho parent)))
|
||||
label parent))))))
|
||||
|
||||
(define root-menu-frame #f)
|
||||
(define (set-root-menu-frame! f)
|
||||
(set! root-menu-frame f)
|
||||
(set-root-menu-wx-frame! (mred->wx f)))
|
||||
|
||||
(define (get-top-level-windows)
|
||||
(remq root-menu-frame (map wx->mred (wx:get-top-level-windows))))
|
||||
|
||||
|
|
@ -313,4 +308,18 @@
|
|||
|
||||
(define (check-frame-parent/false who p)
|
||||
(unless (or (not p) (is-a? p frame%))
|
||||
(raise-type-error (who->name who) "frame% object or #f" p))))
|
||||
(raise-type-error (who->name who) "frame% object or #f" p)))
|
||||
|
||||
(define root-menu-frame
|
||||
(and (current-eventspace-has-menu-root?)
|
||||
;; The very first frame shown is somehow sticky under Cocoa,
|
||||
;; so create the root frame, show it , and hide it.
|
||||
(let* ([f (make-object (class frame%
|
||||
(define/override (on-exit)
|
||||
(exit))
|
||||
(super-make-object "Root" #f 0 0 -9000 -9000
|
||||
'(no-resize-border no-caption))))]
|
||||
[wx (mred->wx f)])
|
||||
(set-root-menu-wx-frame! wx)
|
||||
(send wx designate-root-frame)
|
||||
f))))
|
||||
|
|
|
|||
|
|
@ -114,6 +114,11 @@
|
|||
(let ([wx (->wx wxb)])
|
||||
(when wx
|
||||
(send wx notify-responder #f))))]
|
||||
[-a _void (windowDidMiniaturize: [_id notification])
|
||||
(when wxb
|
||||
(let ([wx (->wx wxb)])
|
||||
(when wx
|
||||
(send wx force-window-focus))))]
|
||||
[-a _void (toggleToolbarShown: [_id sender])
|
||||
(when wxb
|
||||
(let ([wx (->wx wxb)])
|
||||
|
|
@ -136,13 +141,25 @@
|
|||
(values f
|
||||
(and f (send f get-eventspace))))))
|
||||
|
||||
(set-eventspace-hook! (lambda (w)
|
||||
(or (and w
|
||||
(if (objc-is-a? w MyWindow)
|
||||
(tell #:type _scheme w getEventspace)
|
||||
#f))
|
||||
(and front
|
||||
(send front get-eventspace)))))
|
||||
(set-eventspace-hook! (lambda (evt w)
|
||||
(define (is-mouse-or-key?)
|
||||
(bitwise-bit-set? MouseAndKeyEventMask
|
||||
(tell #:type _NSInteger evt type)))
|
||||
(cond
|
||||
[w
|
||||
(and (or (not root-fake-frame)
|
||||
;; only mouse and key events in the root
|
||||
;; frame need to be dispatched in the root
|
||||
;; eventspace:
|
||||
(not (ptr-equal? w (send root-fake-frame get-cocoa)))
|
||||
(is-mouse-or-key?))
|
||||
(objc-is-a? w MyWindow)
|
||||
(tell #:type _scheme w getEventspace))]
|
||||
[front (send front get-eventspace)]
|
||||
[root-fake-frame
|
||||
(and (is-mouse-or-key?)
|
||||
(send root-fake-frame get-eventspace))]
|
||||
[else #f])))
|
||||
|
||||
(define frame%
|
||||
(class window%
|
||||
|
|
@ -287,12 +304,9 @@
|
|||
(send p set-sheet #f)
|
||||
(tell (tell NSApplication sharedApplication)
|
||||
endSheet: cocoa))))
|
||||
(tellv cocoa deminiaturize: #f)
|
||||
(tellv cocoa orderOut: #f)
|
||||
(let ([next (get-app-front-window)])
|
||||
(cond
|
||||
[next (tellv next makeKeyWindow)]
|
||||
[root-fake-frame (send root-fake-frame install-mb)]
|
||||
[else (void)]))))
|
||||
(force-window-focus)))
|
||||
(register-frame-shown this on?)
|
||||
(let ([num (tell #:type _NSInteger cocoa windowNumber)])
|
||||
(if on?
|
||||
|
|
@ -320,6 +334,20 @@
|
|||
(atomically
|
||||
(direct-show on?)))
|
||||
|
||||
(define/public (force-window-focus)
|
||||
(let ([next (get-app-front-window)])
|
||||
(cond
|
||||
[next (tellv next makeKeyWindow)]
|
||||
[root-fake-frame
|
||||
;; Make key focus shift to root frame:
|
||||
(let ([root-cocoa (send root-fake-frame get-cocoa)])
|
||||
(tellv root-cocoa orderFront: #f)
|
||||
(tellv root-cocoa makeKeyWindow)
|
||||
(tellv root-cocoa orderOut: #f))
|
||||
;; Install root frame's menu bar:
|
||||
(send root-fake-frame install-mb)]
|
||||
[else (void)])))
|
||||
|
||||
(define/private (do-paint-children)
|
||||
(when saved-child
|
||||
(send saved-child paint-children))
|
||||
|
|
@ -350,7 +378,8 @@
|
|||
(send saved-child enable-window (and on? (is-window-enabled?)))))
|
||||
|
||||
(define/override (is-shown?)
|
||||
(tell #:type _bool cocoa isVisible))
|
||||
(or (tell #:type _bool cocoa isVisible)
|
||||
(tell #:type _bool cocoa isMiniaturized)))
|
||||
|
||||
(define/override (is-shown-to-root?)
|
||||
(is-shown?))
|
||||
|
|
@ -534,7 +563,12 @@
|
|||
(def/public-unimplemented on-mdi-activate)
|
||||
(define/public (on-close) #t)
|
||||
(define/public (designate-root-frame)
|
||||
(set! root-fake-frame this))
|
||||
(set! root-fake-frame this)
|
||||
;; The first window shown is somehow sticky, so that it becomes
|
||||
;; the main window if no windows are shown:
|
||||
(tellv cocoa orderFront: #f)
|
||||
(tellv cocoa orderOut: #f)
|
||||
(sync-cocoa-events))
|
||||
(def/public-unimplemented system-menu)
|
||||
|
||||
(define/public (set-modified on?)
|
||||
|
|
|
|||
|
|
@ -22,7 +22,8 @@
|
|||
set-fixup-window-locations!
|
||||
post-dummy-event
|
||||
|
||||
try-to-sync-refresh)
|
||||
try-to-sync-refresh
|
||||
sync-cocoa-events)
|
||||
|
||||
;; from common/queue:
|
||||
current-eventspace
|
||||
|
|
@ -315,7 +316,7 @@
|
|||
(when evt (check-menu-bar-click evt))
|
||||
(and evt
|
||||
(or (not dequeue?)
|
||||
(let ([e (eventspace-hook (tell evt window))])
|
||||
(let ([e (eventspace-hook evt (tell evt window))])
|
||||
(if e
|
||||
(let ([mouse-or-key?
|
||||
(bitwise-bit-set? MouseAndKeyEventMask
|
||||
|
|
@ -374,6 +375,10 @@
|
|||
;; in atomic mode
|
||||
(dispatch-all-ready)))
|
||||
|
||||
(define (sync-cocoa-events)
|
||||
(atomically
|
||||
(dispatch-all-ready)))
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Install an alternate "sleep" function (in the PLT Scheme core)
|
||||
;; that wakes up if any Cocoa event is ready.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user