changed the macro stepper to be responsive to the white-on-black preference

(but there is still some work to do to actually select a reasonable set
 of colors and probably some refactoring, but at least the interface with
 the framework is there now, so the changes should not be hard from here on)

original commit: e74e929a9285a47b67a5228dfd1a68280c6b1243

collects/macro-debugger/syntax-browser/display.rkt

@@ -2,6 +2,7 @@
 (require scheme/class
          scheme/gui
          scheme/list
+         framework
          (rename-in unstable/class-iop
                     [send/i send:]
                     [init-field/i init-field:])
@@ -106,7 +107,7 @@
       (with-unlock text
         (send* text 
           (begin-edit-sequence #f)
-          (change-style unhighlight-d start-position end-position))
+          (change-style (unhighlight-d) start-position end-position))
         (apply-extra-styles)
         (let ([selected-syntax
                (send: controller selection-manager<%>
@@ -157,7 +158,7 @@
           (send delta set-delta-foreground color)
           (send style-list find-or-create-style base-style delta)))
       (define color-styles
-        (list->vector (map color-style (send: config config<%> get-colors))))
+        (list->vector (map color-style (map translate-color (send: config config<%> get-colors)))))
       (define overflow-style (color-style "darkgray"))
       (define color-partition
         (send: controller mark-manager<%> get-primary-partition))
@@ -219,7 +220,7 @@
     ;; draw-secondary-connection : syntax -> void
     (define/private (draw-secondary-connection stx2)
       (for ([r (send: range range<%> get-ranges stx2)])
-        (restyle-range r select-sub-highlight-d)))
+        (restyle-range r (select-sub-highlight-d))))
 
     ;; restyle-range : (cons num num) style-delta% -> void
     (define/private (restyle-range r style)
@@ -258,7 +259,7 @@
 ;; code-style : text<%> number/#f -> style<%>
 (define (code-style text font-size)
   (let* ([style-list (send text get-style-list)]
-         [style (send style-list find-named-style "Standard")])
+         [style (send style-list find-named-style (editor:get-default-color-style-name))])
     (if font-size
         (send style-list find-or-create-style
               style
@@ -274,23 +275,40 @@
 
 ;; Styles
 
-(define (highlight-style-delta color em?)
+(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t])
-  (let ([sd (new style-delta%)])
+  (let* ([sd (new style-delta%)])
-    (unless em? (send sd set-delta-background color))
+    (unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-color)))
     (when em? (send sd set-weight-on 'bold))
     (unless em? (send sd set-underlined-off #t)
       (send sd set-weight-off 'bold))
     sd))
 
+(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)))
+
 (define underline-style-delta
   (let ([sd (new style-delta%)])
     (send sd set-underlined-on #t)
     sd))
 
-(define selection-color "yellow")
+(define (mk-2-constant-style wob-color bow-color)
-(define subselection-color "yellow")
+  (let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)]
+        [bow-version (highlight-style-delta bow-color #f #:translate-color? #f)])
+    (λ ()
+      (if (preferences:get 'framework:white-on-black?)
+          wob-version
+          bow-version))))
 
-(define select-highlight-d (highlight-style-delta selection-color #t))
+(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod"))
-(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
+(define select-sub-highlight-d select-highlight-d)  ;; can get rid of this definition(?).
 
-(define unhighlight-d (highlight-style-delta "white" #f))
+(define unhighlight-d (mk-2-constant-style "black" "white"))

collects/macro-debugger/syntax-browser/image.rkt

@@ -36,7 +36,7 @@ TODO: tacked arrows
 ;; print-syntax-columns : (parameter-of (U number 'infinity))
 (define print-syntax-columns (make-parameter 40))
 
-(define standard-text% (editor:standard-style-list-mixin text%))
+(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%)))
 
 ;; print-syntax-to-png : syntax path -> void
 (define (print-syntax-to-png stx file
@@ -54,7 +54,7 @@ TODO: tacked arrows
   (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
   (define char-width
     (let* ([sl (send t get-style-list)]
-           [style (send sl find-named-style "Standard")]
+           [style (send sl find-named-style (editor:get-default-color-style-name))]
            [font (send style get-font)])
       (send dc set-font font)
       (send dc get-char-width)))
@@ -89,7 +89,7 @@ TODO: tacked arrows
 (define (prepare-editor stx columns)
   (define t (new standard-text%))
   (define sl (send t get-style-list))
-  (send t change-style (send sl find-named-style "Standard"))
+  (send t change-style (send sl find-named-style (editor:get-default-color-style-name)))
   (print-syntax-to-editor stx t 
                           (new controller%) (new syntax-prefs/readonly%)
                           columns (send t last-position))

collects/macro-debugger/syntax-browser/widget.rkt

@@ -33,7 +33,7 @@
       (new panel:horizontal-dragable% (parent -main-panel)))
     (define -text (new browser-text%))
     (define -ecanvas
-      (new editor-canvas% (parent -split-panel) (editor -text)))
+      (new canvas:color% (parent -split-panel) (editor -text)))
     (define -props-panel (new horizontal-panel% (parent -split-panel)))
     (define props
       (new properties-view%
@@ -251,13 +251,20 @@
 ;; Specialized classes for widget
 
 (define browser-text%
+  (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
     (class (text:arrows-mixin
             (text:tacking-mixin
              (text:hover-drawings-mixin
               (text:hover-mixin
                (text:hide-caret/selection-mixin
-              (editor:standard-style-list-mixin text:basic%))))))
+                (text:foreground-color-mixin
-    (inherit set-autowrap-bitmap)
+                 (editor:standard-style-list-mixin text:basic%)))))))
-    (define/override (default-style-name) "Basic")
+      (inherit set-autowrap-bitmap get-style-list)
+      (define/override (default-style-name) browser-text-default-style-name)
       (super-new (auto-wrap #t))
-    (set-autowrap-bitmap #f)))
+      (let* ([sl (get-style-list)]
+             [standard (send sl find-named-style (editor:get-default-color-style-name))]
+             [browser-basic (send sl find-or-create-style standard
+                                  (make-object style-delta% 'change-family 'default))])
+        (send sl new-named-style browser-text-default-style-name browser-basic))
+      (set-autowrap-bitmap #f))))