From 3219cfd0b6f600e3ee427f05a153b35b2ce7cd94 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 8 Jun 2010 10:53:50 -0500 Subject: [PATCH] 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 --- .../macro-debugger/syntax-browser/display.rkt | 42 +++++++++++++------ .../macro-debugger/syntax-browser/image.rkt | 6 +-- .../macro-debugger/syntax-browser/widget.rkt | 29 ++++++++----- 3 files changed, 51 insertions(+), 26 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index b79f081..653234d 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/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?) - (let ([sd (new style-delta%)]) - (unless em? (send sd set-delta-background color)) +(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t]) + (let* ([sd (new style-delta%)]) + (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 subselection-color "yellow") +(define (mk-2-constant-style wob-color bow-color) + (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-sub-highlight-d (highlight-style-delta subselection-color #f)) +(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod")) +(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")) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index d8151c5..7e5774a 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/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)) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 30af2e7..598d3b6 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/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% - (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%)))))) - (inherit set-autowrap-bitmap) - (define/override (default-style-name) "Basic") - (super-new (auto-wrap #t)) - (set-autowrap-bitmap #f))) + (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 + (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%))))))) + (inherit set-autowrap-bitmap get-style-list) + (define/override (default-style-name) browser-text-default-style-name) + (super-new (auto-wrap #t)) + (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))))