use color-prefs:white-on-block-color-scheme? instead of white-on-black-panel-scheme? or the 'framework:white-on-black? preference

Author: rfindler

drracket-core-lib/drracket/private/app.rkt

@@ -1,6 +1,7 @@
 #lang racket/unit
 
 (require racket/class
+         racket/match
          string-constants
          racket/gui/base
          framework
@@ -11,7 +12,8 @@
          "local-member-names.rkt"
          "frame-icon.rkt"
          "insulated-read-language.rkt"
-         pict/snip pict)
+         pict/snip pict
+         mrlib/panel-wob)
 
 (import [prefix drracket:unit: drracket:unit^]
         [prefix drracket:frame: drracket:frame/int^]
@@ -95,7 +97,7 @@
      (send dc set-scale mb-scale-factor mb-scale-factor)
      (send dc set-smoothing 'smoothed)
      (send dc set-pen "black" 1 'transparent)
-     (when (preferences:get 'framework:white-on-black?)
+     (when (color-prefs:white-on-black-color-scheme?)
        (define old-clip (send dc get-clipping-region))
        (define rgn (new region% [dc dc]))
        (define pen (send dc get-pen))
@@ -159,7 +161,7 @@
           usual-style))
   (send clickback-style set-delta
         (gui-utils:get-clickback-delta
-         (preferences:get 'framework:white-on-black?)))
+         (color-prefs:white-on-black-color-scheme?)))
 
   (define (insert/clickback str clickback)
     (send e change-style clickback-style)
@@ -269,10 +271,14 @@
     (send sl end-style-change-sequence))
   (define remove-callback
     (preferences:add-callback
-     'framework:white-on-black?
+     'framework:white-on-black-mode?
      (λ (p v)
-       (update-wob v))))
-  (update-wob (preferences:get 'framework:white-on-black?))
+       (update-wob
+        (match v
+          ['platform (white-on-black-panel-scheme?)]
+          [#t #t]
+          [#f #f])))))
+  (update-wob (color-prefs:white-on-black-color-scheme?))
   (set! remove-callback-defined? #t)
 
   (send* e

drracket-core-lib/drracket/private/debug.rkt

@@ -865,7 +865,7 @@
         (send text insert (string-constant more-stack-frames))
         (define hyper-end (send text last-position))
         (send text change-style (gui-utils:get-clickback-delta
-                                 (preferences:get 'framework:white-on-black?))
+                                 (color-prefs:white-on-black-color-scheme?))
               hyper-start hyper-end)
         (send text set-clickback
               hyper-start hyper-end
@@ -924,7 +924,7 @@
     (send text insert " ")
     (change-regular-style text start-pos end-pos)
     (send text change-style 
-          (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?))
+          (gui-utils:get-clickback-delta (color-prefs:white-on-black-color-scheme?))
           start-pos 
           end-pos)
     (send text set-clickback
@@ -2168,7 +2168,7 @@
                 (cond
                   [(string? expr-src)
                    (send src-loc-editor change-style
-                         (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?))
+                         (gui-utils:get-clickback-delta (color-prefs:white-on-black-color-scheme?))
                          before after)
                    (let ([after (send src-loc-editor last-position)])
                      (send src-loc-editor set-clickback 
@@ -2177,7 +2177,7 @@
                              (open-file-and-goto-position expr-src (syntax-position expr)))))]
                   [(is-a? expr-src editor:basic<%>)
                    (send src-loc-editor change-style
-                         (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?))
+                         (gui-utils:get-clickback-delta (color-prefs:white-on-black-color-scheme?))
                          before after)
                    (send src-loc-editor set-clickback
                          before after

drracket-core-lib/drracket/private/insert-large-letters.rkt

@@ -6,8 +6,8 @@
 (require/typed racket/gui/base
                [get-label-background-color
                 (-> (Instance Color%))])
-(require/typed mrlib/panel-wob
-               [white-on-black-panel-scheme?
+(require/typed framework/main
+               [color-prefs:white-on-black-color-scheme?
                 (-> Boolean)])
 (provide insert-large-letters)
 
@@ -221,7 +221,7 @@
       (define bm* bm)
       (cond
         [bm*
-         (when (white-on-black-panel-scheme?)
+         (when (color-prefs:white-on-black-color-scheme?)
            (invert-bm bm*))
          (min-width (send bm* get-width))
          (min-height (send bm* get-height))]

drracket-core-lib/drracket/private/language-configuration.rkt

@@ -684,7 +684,7 @@
                  (define/override (on-paint)
                    (define dc (get-dc))
                    (send dc set-font normal-control-font)
-                   (when (white-on-black-panel-scheme?)
+                   (when (color-prefs:white-on-black-color-scheme?)
                      (send dc set-text-foreground "white"))
                    (send dc draw-text "..." 0 0))
                  (define/override (on-event evt)
@@ -951,7 +951,7 @@
                         (when second-number
                           (send item set-second-number second-number))
                         (send text insert position)
-                        (when (white-on-black-panel-scheme?)
+                        (when (color-prefs:white-on-black-color-scheme?)
                           (send text change-style wob-style-delta
                                 0 (send text last-position)))
                         (when delta
@@ -988,7 +988,7 @@
                                     (send editor insert position)
                                     (send editor change-style small-size-delta pos (+ pos 1))
                                     (send editor change-style
-                                          (if (white-on-black-panel-scheme?)
+                                          (if (color-prefs:white-on-black-color-scheme?)
                                               wob-section-style-delta
                                               bow-section-style-delta)
                                           (+ pos 1) (send editor last-position)))
@@ -1005,7 +1005,7 @@
                                   (send new-list open)
                                   (define editor (send new-list get-editor))
                                   (send editor insert position)
-                                  (when (white-on-black-panel-scheme?)
+                                  (when (color-prefs:white-on-black-color-scheme?)
                                     (send editor change-style wob-style-delta
                                           0 (send editor last-position)))
                                   (hash-set! ht (string->symbol position) x)
@@ -1383,7 +1383,7 @@
                  (send (send t get-style-list) basic-style)
                  before (send t last-position))])
         (send t change-style size-sd before (send t last-position))
-        (when (white-on-black-panel-scheme?)
+        (when (color-prefs:white-on-black-color-scheme?)
           (send t change-style wob-style-delta before (send t last-position))))
       (when (send normal-control-font get-size-in-pixels)
         (send size-sd set-size-in-pixels-on #t))
@@ -2249,7 +2249,7 @@
         (let ([list (editor:get-standard-style-list)]
               [green-style-delta (make-object style-delta% 'change-family 'default)])
           (send green-style-delta set-delta-foreground
-                (if (preferences:get 'framework:white-on-black?)
+                (if (color-prefs:white-on-black-color-scheme?)
                     (make-object color% 170 151 240)
                     "DarkViolet"))
           (send green-style-delta set-delta 'change-italic)
@@ -2305,7 +2305,7 @@
 
           (send txt insert words)
           (send txt change-style
-                (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?))
+                (gui-utils:get-clickback-delta (color-prefs:white-on-black-color-scheme?))
                 0
                 (send txt last-position))))
 
@@ -2392,7 +2392,7 @@
              (parent racketeer-panel) 
              (label (string-constant use-language-in-source))
              (color (send the-color-database find-color
-                          (if (white-on-black-panel-scheme?)
+                          (if (color-prefs:white-on-black-color-scheme?)
                               "deepskyblue"
                               "blue")))
              (callback (λ () (change-current-lang-to
@@ -2462,7 +2462,7 @@
                (define old-tf (send dc get-text-foreground))
                (send dc set-text-foreground
                      (or color
-                         (if (white-on-black-panel-scheme?)
+                         (if (color-prefs:white-on-black-color-scheme?)
                              (send the-color-database find-color "lightgray")
                              (send the-color-database find-color "black"))))
                (send dc set-font font)
@@ -2502,7 +2502,7 @@
              (parent panel2) 
              (label lang-name)
              (color (send the-color-database find-color
-                          (if (white-on-black-panel-scheme?)
+                          (if (color-prefs:white-on-black-color-scheme?)
                               "deepskyblue"
                               "blue")))
              (callback (λ () (change-current-lang-to lang)))

drracket-core-lib/drracket/private/main.rkt

@@ -25,7 +25,8 @@
          net/url
          racket/place
          racket/future
-         mrlib/syntax-browser)
+         mrlib/syntax-browser
+         mrlib/panel-wob)
 
 (import [prefix drracket:app: drracket:app^]
         [prefix drracket:unit: drracket:unit^]
@@ -754,18 +755,22 @@
           (if wob? wob-color bow-color))
     (send sd set-delta-background bkg-color)
     (send st set-delta sd))
-  (set-the-color (preferences:get 'framework:white-on-black?)
+  (set-the-color (color-prefs:white-on-black-color-scheme?)
                  (color-prefs:lookup-in-color-scheme
                   'framework:basic-canvas-background))
   (preferences:add-callback
-   'framework:white-on-black?
-   (λ (name b) (set-the-color b
-                              (color-prefs:lookup-in-color-scheme
-                               'framework:basic-canvas-background))))
+   'framework:white-on-black-mode?
+   (λ (name v)
+     (set-the-color (match v
+                      ['platform (white-on-black-panel-scheme?)]
+                      [#t #t]
+                      [#f #f])
+                    (color-prefs:lookup-in-color-scheme
+                     'framework:basic-canvas-background))))
   (color-prefs:register-color-scheme-entry-change-callback
    'framework:basic-canvas-background
-   (λ (bkg-color) (set-the-color (preferences:get 'framework:white-on-black?)
-                             bkg-color))))
+   (λ (bkg-color) (set-the-color (color-prefs:white-on-black-color-scheme?)
+                                 bkg-color))))
 
 (add-and-monitor-render-syntax-style render-syntax-subtitle-color-style-name
                                      "navy"

drracket-core-lib/drracket/private/module-language.rkt

@@ -739,6 +739,7 @@
                     [parent dynamic-panel]))
          (set! run-submodules-choice 
                (new (class name-message%
+                      (define/override (wob?) (color-prefs:white-on-black-color-scheme?))
                       (define/override (fill-popup menu reset)
                         (for ([item (in-list (preferences:get 'drracket:submodules-to-choose-from))]
                               [x (in-naturals)])
@@ -1538,7 +1539,7 @@
               (send dc set-brush "red" 'solid)
               (send dc set-pen "red" 1 'transparent)
               (send dc set-alpha 
-                    (if (preferences:get 'framework:white-on-black?)
+                    (if (color-prefs:white-on-black-color-scheme?)
                         .5
                         .25))
 
@@ -2050,7 +2051,7 @@
       (define/override (on-paint)
         (define dc (get-dc))
         (define-values (cw ch) (get-client-size))
-        (send dc set-text-foreground (if (white-on-black-panel-scheme?)
+        (send dc set-text-foreground (if (color-prefs:white-on-black-color-scheme?)
                                          (if err? "pink" "white")
                                          (if err? "firebrick" "black")))
         (define-values (tot-th gap-space) (height/gap-space dc))
@@ -2680,7 +2681,7 @@
               (when (rectangles-intersect?
                      left top right bottom
                      tx ty (+ tx tw) (+ ty th))
-                (send dc set-text-foreground (if (white-on-black-panel-scheme?) "white" "black"))
+                (send dc set-text-foreground (if (color-prefs:white-on-black-color-scheme?) "white" "black"))
                 (send dc set-alpha (* fade-amount .5))
                 (send dc draw-text id (+ dx tx) (+ dy ty) 'grapheme)
                 (send dc set-alpha α)

drracket-core-lib/drracket/private/rep.rkt

@@ -350,7 +350,7 @@ TODO
     error-text-style-delta)
 
   (define (click-delta)
-    (gui-utils:get-clickback-delta (preferences:get 'framework:white-on-black?)))  
+    (gui-utils:get-clickback-delta (color-prefs:white-on-black-color-scheme?)))
 
   (define (get-warning-style-delta)
     (define warning-style-delta (make-object style-delta% 'change-bold))

drracket-core-lib/drracket/private/syncheck/blueboxes-gui.rkt

@@ -35,7 +35,7 @@
 
 (define corner-radius 48)
 (define bow-blue-box-color (make-object color% 232 240 252))
-(define (get-blue-box-color) (if (preferences:get 'framework:white-on-black?)
+(define (get-blue-box-color) (if (color-prefs:white-on-black-color-scheme?)
                                  (send the-color-database find-color "navy") ;; MidnightBlue
                                  bow-blue-box-color))
 (define bow-var-color (make-object color% 68 68 68))
@@ -49,7 +49,7 @@
 (define box-gradient-stop-color-wob (make-object color% 8 8 8))
 (define (make-blue-box-gradient-pen x y w h)
   (define stops (list (list 0 (get-blue-box-color))
-                      (list 1 (if (preferences:get 'framework:white-on-black?)
+                      (list 1 (if (color-prefs:white-on-black-color-scheme?)
                                   box-gradient-stop-color-wob
                                   box-gradient-stop-color-bow))))
   (make-object brush% "black" 'solid #f
@@ -885,7 +885,7 @@
         pi (* pi #e1.5))
 
   (send dc set-brush
-        (if (preferences:get 'framework:white-on-black?)
+        (if (color-prefs:white-on-black-color-scheme?)
             "black"
             "white")
         'solid)
@@ -938,7 +938,7 @@
     (define-values (read-more-w read-more-h read-more-d read-more-a)
       (send dc get-text-extent sc-read-more... (get-read-more-underline-font sl)))
     (send dc set-text-foreground
-          (if (preferences:get 'framework:white-on-black?)
+          (if (color-prefs:white-on-black-color-scheme?)
               "lightblue"
               "darkblue"))
     (send dc draw-text 
@@ -970,7 +970,7 @@
       (send dc get-text-extent (list-ref strs 0) label-font 'grapheme))
 
     (send dc set-text-foreground
-          (if (preferences:get 'framework:white-on-black?)
+          (if (color-prefs:white-on-black-color-scheme?)
               wob-var-color
               bow-var-color))
     (for/fold ([y (if label-overlap? 

drracket-core-lib/drracket/private/syncheck/gui.rkt

@@ -1022,7 +1022,7 @@ If the namespace does not, they are colored the unbound color.
                   ;; preference so we don't have to have the preference set up
                   ;; in the other place when running check syntax in online mode.
                   (define color 
-                    (if (preferences:get 'framework:white-on-black?)
+                    (if (color-prefs:white-on-black-color-scheme?)
                         (cond
                           [(equal? raw-color "palegreen") "darkgreen"]
                           [else raw-color])
@@ -2098,7 +2098,7 @@ If the namespace does not, they are colored the unbound color.
           (define old-text-foreground (send dc get-text-foreground))
           (define old-text-mode (send dc get-text-mode))
           (define old-alpha (send dc get-alpha))
-          (define white-on-black? (preferences:get 'framework:white-on-black?))
+          (define white-on-black? (color-prefs:white-on-black-color-scheme?))
           (send dc set-font
                 (send the-font-list find-or-create-font
                       (send old-font get-point-size)