From ed46c25db536207e3280db4cd3d159d8ac8aef4a Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 8 Jun 2010 14:11:44 -0600
Subject: [PATCH] macro-debugger: made properties display respect
 inverted-colors mode

original commit: b6b8e299572c53f2b75646755f46badf92a5ffd6
---
 .../macro-debugger/syntax-browser/display.rkt | 18 +++------------
 .../macro-debugger/syntax-browser/prefs.rkt   |  6 ++++-
 .../syntax-browser/properties.rkt             | 22 +++++++++++++++++--
 3 files changed, 28 insertions(+), 18 deletions(-)

diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt
index f3b640e..ba42808 100644
--- a/collects/macro-debugger/syntax-browser/display.rkt
+++ b/collects/macro-debugger/syntax-browser/display.rkt
@@ -9,6 +9,7 @@
          (only-in mzlib/etc begin-with-definitions)
          "pretty-printer.ss"
          "interfaces.ss"
+         "prefs.ss"
          "util.ss")
 (provide print-syntax-to-editor
          code-style)
@@ -281,7 +282,7 @@
 ;; translate-color : color-string -> color%
 (define (translate-color color-string)
   (let ([c (make-object color% color-string)])
-    (if (preferences:get 'framework:white-on-black?)
+    (if (pref:invert-colors?)
         (let-values ([(r* g* b*)
                       (lightness-invert (send c red) (send c green) (send c blue))])
           #|
@@ -292,19 +293,6 @@
           (make-object color% r* g* b*))
         c)))
 
-#;
-(define (translate-color color)
-  (let ([reversed-color
-         (case (string->symbol (string-downcase color))
-           [(white) "black"]
-           [(black) "white"]
-           [(yellow) "goldenrod"]
-           [else (printf "unknown color ~s\n" color)
-                 color])])
-    (if (preferences:get 'framework:white-on-black?)
-        reversed-color
-        color)))
-
 ;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8)
 (define (lightness-invert r g b)
   (define (c x)
@@ -393,7 +381,7 @@
   (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)]
         [bow-version (highlight-style-delta bow-color em? #:translate-color? #f)])
     (λ ()
-      (if (preferences:get 'framework:white-on-black?)
+      (if (pref:invert-colors?)
           wob-version
           bow-version))))
 
diff --git a/collects/macro-debugger/syntax-browser/prefs.rkt b/collects/macro-debugger/syntax-browser/prefs.rkt
index 8df1e63..63e245b 100644
--- a/collects/macro-debugger/syntax-browser/prefs.rkt
+++ b/collects/macro-debugger/syntax-browser/prefs.rkt
@@ -7,7 +7,9 @@
 (provide prefs-base%
          syntax-prefs-base%
          syntax-prefs%
-         syntax-prefs/readonly%)
+         syntax-prefs/readonly%
+
+         pref:invert-colors?)
 
 (preferences:set-default 'SyntaxBrowser:Width 700 number?)
 (preferences:set-default 'SyntaxBrowser:Height 600 number?)
@@ -19,6 +21,8 @@
 (define pref:props-percentage (pref:get/set 'SyntaxBrowser:PropertiesPanelPercentage))
 (define pref:props-shown? (pref:get/set 'SyntaxBrowser:PropertiesPanelShown))
 
+(define pref:invert-colors? (pref:get/set 'framework:white-on-black?))
+
 (define prefs-base%
   (class object%
     ;; suffix-option : SuffixOption
diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/collects/macro-debugger/syntax-browser/properties.rkt
index f6a1a9d..a0d30f1 100644
--- a/collects/macro-debugger/syntax-browser/properties.rkt
+++ b/collects/macro-debugger/syntax-browser/properties.rkt
@@ -1,6 +1,7 @@
 #lang scheme/base
 (require scheme/class
          scheme/gui
+         framework
          (rename-in unstable/class-iop
                     [send/i send:])
          "interfaces.ss"
@@ -9,6 +10,23 @@
 (provide properties-view%
          properties-snip%)
 
+(define color-text-default-style-name
+  "macro-debugger/syntax-browser/properties color-text% basic")
+
+(define color-text%
+  (class (editor:standard-style-list-mixin text:basic%)
+    (inherit get-style-list)
+    (define/override (default-style-name)
+      color-text-default-style-name)
+    (super-new)
+    (let* ([sl (get-style-list)]
+           [standard
+            (send sl find-named-style (editor:get-default-color-style-name))]
+           [basic
+            (send sl find-or-create-style standard
+                  (make-object style-delta% 'change-family 'default))])
+      (send sl new-named-style color-text-default-style-name basic))))
+
 ;; properties-view-base-mixin
 (define properties-view-base-mixin
   (mixin () ()
@@ -22,7 +40,7 @@
     (define mode 'term)
 
     ;; text : text%
-    (field (text (new text%)))
+    (field (text (new color-text%)))
     (field (pdisplayer (new properties-displayer% (text text))))
 
     (send: controller selection-manager<%> listen-selected-syntax
@@ -122,7 +140,7 @@
            (callback
             (lambda (tp e)
               (set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
-    (define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
+    (define ecanvas (new canvas:color% (editor text) (parent tab-panel)))))
 
 ;; properties-displayer%
 (define properties-displayer%