add application-dark-mode-handler

gui-doc/mrlib/scribblings/panel-wob.scrbl

@@ -6,11 +6,14 @@
 @defmodule[mrlib/panel-wob]
 
 @defproc[(white-on-black-panel-scheme?) boolean?]{
- Determines if the foreground color of the panel background
- is lighter than the background color. If they appear to
- be the same, @racket[white-on-black-panel-scheme?] returns
- @racket[#f].
-
  This predicate is intended to determine if the underlying
- operating system is in a ``dark'' mode.
+ operating system is in a dark mode.
+
+ Under relatively recent versions of Mac OS, it queries dark
+ mode directly. See also @racket[application-dark-mode-handler].
+
+ On other platforms, it determines if the foreground color
+ of the panel background is lighter than the background
+ color. If they appear to be the same,
+ @racket[white-on-black-panel-scheme?] returns @racket[#f].
 }

gui-doc/scribblings/gui/system-menu-funcs.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "common.rkt")
+@(require "common.rkt"
+          (for-label mrlib/panel-wob))
 
 @title{System Menus}
 
@@ -152,3 +153,22 @@ If the current eventspace is not the initial eventspace, this
 procedure returns @racket[void] (when called with zero arguments)
 or has no effect (when called with a handler).
 }
+
+@defproc*[([(application-dark-mode-handler)
+            (-> any)]
+           [(application-dark-mode-handler [handler-thunk (-> any)])
+            void?])]{
+
+ When the current @tech{eventspace} is the initial
+ eventspace this procedure retrieves or installs a thunk that
+ is called under Mac OS when the OS switches to or from dark mode.
+ See also @racket[white-on-black-panel-scheme?].
+
+ The default handler does nothing.
+
+ If the current eventspace is not the initial eventspace,
+ this procedure returns @racket[void] (when called with zero
+ arguments) or has no effect (when called with a handler).
+
+ @history[#:added "1.68"]
+}

gui-lib/info.rkt

@@ -34,7 +34,7 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.67")
+(define version "1.68")
 
 (define license
   '(Apache-2.0 OR MIT))

gui-lib/mred/mred-sig.rkt

@@ -12,6 +12,7 @@ application-file-handler
 application-preferences-handler
 application-quit-handler
 application-start-empty-handler
+application-dark-mode-handler
 area-container-window<%>
 area-container<%>
 area<%>

gui-lib/mred/private/app.rkt

@@ -11,6 +11,7 @@
            application-quit-handler
            application-file-handler
            application-start-empty-handler
+           application-dark-mode-handler
            current-eventspace-has-standard-menus?
            current-eventspace-has-menu-root?
            eventspace-handler-thread)
@@ -104,6 +105,18 @@
 		    (lambda (v) (unless v (wx:cancel-quit)) v)
                     void)]))
 
+  (define application-dark-mode-handler
+    (case-lambda
+      [() (or (and (wx:main-eventspace? (wx:current-eventspace))
+                   (app-handler-orig (wx:application-dark-mode-handler)))
+              void)]
+      [(proc)
+       (set-handler! 'application-dark-mode-handler proc
+                     wx:application-dark-mode-handler
+                     0
+                     values
+                     void)]))
+
   (define saved-files null)
 
   (define default-application-file-handler

gui-lib/mred/private/kernel.rkt

@@ -40,4 +40,5 @@
          application-quit-handler
          application-about-handler
          application-pref-handler
-         application-start-empty-handler)
+         application-start-empty-handler
+         application-dark-mode-handler)

gui-lib/mred/private/mred.rkt

@@ -288,6 +288,7 @@
 	   application-quit-handler
 	   application-file-handler
 	   application-start-empty-handler
+           application-dark-mode-handler
 	   current-eventspace-has-standard-menus?
 	   current-eventspace-has-menu-root?
 	   eventspace-handler-thread

gui-lib/mred/private/wx/cocoa/queue.rkt

@@ -90,8 +90,19 @@
   [-a _void (applicationDidFinishLaunching: [_id notification])
       ;; Create an empty windows menu for right clicking in the dock
       (tell app setWindowsMenu: (tell (tell NSMenu alloc) init))
+      (when (version-10.9-or-later?)
+        (tell app addObserver:
+              self
+              forKeyPath: #:type _NSString "effectiveAppearance"
+              options: #f
+              context: #f))
       (unless got-file?
         (queue-start-empty-event))]
+  [-a _void (observeValueForKeyPath: [_NSString keyPath] ofObject: ofObject change: change context: context)
+      ;; we add an observer only for "effectiveAppearance",
+      ;; so no check is needed to know why we got here
+      (queue-dark-mode-event)
+      (void)]
   [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?])
       ;; If we have any visible windows, return #t to do the default thing.
       ;; Otherwise return #f, because we don't want any invisible windows resurrected.

gui-lib/mred/private/wx/common/handlers.rkt

@@ -6,6 +6,7 @@
               application-quit-handler
               application-about-handler
               application-pref-handler
+              application-dark-mode-handler
 
               nothing-application-pref-handler
               nothing-application-about-handler))
@@ -63,3 +64,10 @@
   (case-lambda
    [(proc) (set! aph proc)]
    [() aph]))
+
+(define (nothing-application-dark-mode-handler) (void))
+(define admh nothing-application-dark-mode-handler)
+(define application-dark-mode-handler
+  (case-lambda
+   [(proc) (set! admh proc)]
+   [() admh]))

gui-lib/mred/private/wx/common/queue.rkt

@@ -59,6 +59,7 @@
               queue-about-event
               queue-file-event
               queue-start-empty-event
+              queue-dark-mode-event
 
               begin-busy-cursor
               end-busy-cursor
@@ -604,6 +605,10 @@
   (queue-event main-eventspace (application-start-empty-handler)
                'med))
 
+(define (queue-dark-mode-event)
+  ;; called in event-pump thread
+  (queue-event main-eventspace (application-dark-mode-handler) 'med))
+
 (define (begin-busy-cursor) 
   (let ([e (current-eventspace)])
     (atomically