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))))