From ae528ecf8b13924e16ca516d76ec79faf1768295 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 30 Oct 2010 21:13:49 -0600 Subject: [PATCH] cocoa: hack around a problem with application hiding original commit: da6397e00657b85e3e6108ac69d5cb06cfaf45e2 --- collects/mred/private/wx/cocoa/queue.rkt | 41 ++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 6c9f005b..31eb3b60 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -61,8 +61,6 @@ ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly (void)]) -(tellv app finishLaunching) - ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive ;; keyboard events. @@ -95,6 +93,8 @@ (void (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) +(tellv app finishLaunching) + ;; ------------------------------------------------------------ ;; Create an event to post when MzScheme has been sleeping but is ;; ready to wake up @@ -189,6 +189,38 @@ [source (CFSocketCreateRunLoopSource (CFAllocatorGetDefault) cfs 0)]) (CFRunLoopAddSource rl source kCFRunLoopDefaultMode)) +;; ------------------------------------------------------------ +;; Another hack: +;; Install a run-loop observer that noticed when the core run loop +;; is exited multiple times during a single wait for a Cocoa event. +;; When that happens, it's a sign that something has gone wrong, +;; and we should interrupt the event wait and try again. This happens +;; when the user hides the application and then clicks on the dock +;; icon. (But why does that happen?) + +(define _Boolean _BOOL) +(define-cf kCFRunLoopCommonModes _pointer) +(define-cf CFRunLoopObserverCreate (_fun _pointer ; CFAllocatorRef + _int ; CFOptionFlags + _Boolean ; repeats? + _CFIndex ; order + (_fun #:atomic? #t _pointer _int _pointer -> _void) + _pointer ; CFRunLoopObserverContext + -> _pointer)) +(define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void)) +(define-cf CFRunLoopGetMain (_fun -> _pointer)) +(define kCFRunLoopExit (arithmetic-shift 1 7)) +(define-mz scheme_signal_received (_fun -> _void)) +(define already-exited? #f) +(define sleeping? #f) +(define (exiting-run-loop x y z) + (when sleeping? + (if already-exited? + (scheme_signal_received) + (set! already-exited? #t)))) +(let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)]) + (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes)) + ;; ------------------------------------------------------------ ;; Cocoa event pump @@ -330,9 +362,12 @@ ;; Called through an atomic callback: (define (sleep-until-event secs fds) + (set! sleeping? #t) + (set! already-exited? #f) (scheme_start_sleeper_thread scheme_sleep secs fds write_sock) (check-one-event #t #f) ; blocks until an event is ready - (scheme_end_sleeper_thread)) + (scheme_end_sleeper_thread) + (set! sleeping? #f)) (define (cocoa-install-event-wakeup) (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it