diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index b2b3dc2c30..da261336b1 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -364,6 +364,45 @@ (preferences:set 'framework:exit-when-no-frames #f)] [else (preferences:set 'framework:exit-when-no-frames #t)]) + + + (let* ([sl (editor:get-standard-style-list)] + [sd (make-object style-delta%)]) + (send sd set-delta-foreground (make-object color% 255 0 0)) + (send sl new-named-style + "drscheme:text:ports err" + (send sl find-or-create-style + (send sl find-named-style "text:ports err") + sd))) + (define repl-error-pref 'drscheme:repl:error-color) + (define repl-out-pref 'drscheme:repl:out-color) + (define repl-value-pref 'drscheme:repl:value-color) + (color-prefs:register-color-pref repl-value-pref + "text:ports value" + (make-object color% 0 0 175)) + (color-prefs:register-color-pref repl-error-pref + "text:ports err" + (let ([sd (make-object style-delta% 'change-italic)]) + (send sd set-delta-foreground (make-object color% 255 0 0)) + sd)) + (color-prefs:register-color-pref repl-out-pref + "text:ports out" + (make-object color% 150 0 150)) + (color-prefs:add-to-preferences-panel + (string-constant repl-colors) + (λ (parent) + (color-prefs:build-color-selection-panel parent + repl-value-pref + "text:ports value" + (string-constant repl-value-color)) + (color-prefs:build-color-selection-panel parent + repl-error-pref + "text:ports err" + (string-constant repl-error-color)) + (color-prefs:build-color-selection-panel parent + repl-out-pref + "text:ports out" + (string-constant repl-out-color)))) ;; Check for any files lost last time. ;; Ignore the framework's empty frames test, since diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index c3790a3164..cb6a72633e 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -1572,7 +1572,6 @@ TODO (floor (/ width char-width)))]) (send dc set-font old-font) (pretty-print-columns new-columns)))))) - (super-new) (auto-wrap #t) (set-styles-sticky #f) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index e414613230..52ec47a1ea 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -1365,8 +1365,8 @@ "Extracts the z component of \\var{xyz}.") (color-prefs:register-color-pref - (symbol? string? (is-a?/c color%) . -> . void?) - (pref-name style-name color) + (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)) . -> . void?) + (pref-name style-name color/sd) "This function registers a color preference and initializes the" "style list returned from" "@flink editor:get-standard-style-list %" @@ -1375,9 +1375,10 @@ "and " "@flink preferences:set-un/marshall " "to install the pref for \\var{pref-name}, using" - "\\var{color} as the default color. The preference" + "\\var{color/sd} as the default color. The preference" "is bound to a \\iscmclass{style-delta}, and initially the \\iscmclass{style-delta}" - "changes the foreground color to \\var{color}." + "changes the foreground color to \\var{color/sd}, unless \\var{color/sd} is a style" + "delta already, in which case it is just used directly." "Then, it calls " "@flink editor:set-standard-style-list-delta" "passing the \\var{style-name} and the current value" diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index 57e6921a2c..644eed111e 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -17,7 +17,6 @@ ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void ;; constructs a panel containg controls to configure the preferences panel. - ;; BUG: style changes don't update the check boxes. (define build-color-selection-panel (opt-lambda (parent pref-sym @@ -61,23 +60,23 @@ (send delta set-style-on 'slant) (send delta set-style-off 'base)) (λ (delta) - (send delta set-style-on 'base) - (send delta set-style-off 'slant)))) + (send delta set-style-on 'normal) + (send delta set-style-off 'base)))) (define bold-check (make-check (string-constant cs-bold) (λ (delta) (send delta set-weight-on 'bold) (send delta set-weight-off 'base)) (λ (delta) - (send delta set-weight-on 'base) - (send delta set-weight-off 'bold)))) + (send delta set-weight-on 'normal) + (send delta set-weight-off 'base)))) (define underline-check (make-check (string-constant cs-underline) (λ (delta) (send delta set-underlined-on #t) (send delta set-underlined-off #f)) (λ (delta) - (send delta set-underlined-off #t) + (send delta set-underlined-off #f) (send delta set-underlined-on #f)))) (define color-button (and (>= (get-display-depth) 8) @@ -107,9 +106,18 @@ (send e insert example-text) (send e set-position 0) - (send slant-check set-value (eq? (send style get-style) 'slant)) + (send slant-check set-value (or (eq? (send style get-style) 'slant) + (eq? (send style get-style) 'italic))) (send bold-check set-value (eq? (send style get-weight) 'bold)) - (send underline-check set-value (send style get-underlined)))) + (send underline-check set-value (send style get-underlined)) + (preferences:add-callback + pref-sym + (λ (p sd) + (send slant-check set-value (or (eq? (send style get-style) 'slant) + (eq? (send style get-style) 'italic))) + (send bold-check set-value (eq? (send sd get-weight-on) 'bold)) + (send underline-check set-value (send sd get-underlined-on)))) + (void))) (define (add/mult-set m v) (send m set (car v) (cadr v) (caddr v))) @@ -285,9 +293,14 @@ panel)))) ;; see docs - (define (register-color-pref pref-name style-name color) - (let ([sd (new style-delta%)]) - (send sd set-delta-foreground color) + (define (register-color-pref pref-name style-name color/sd) + (let ([sd (cond + [(is-a? color/sd style-delta%) + color/sd] + [else + (let ([sd (new style-delta%)]) + (send sd set-delta-foreground color/sd) + sd)])]) (preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))) (preferences:set-un/marshall pref-name marshall-style unmarshall-style) (preferences:add-callback pref-name diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index fc630ba40d..51620da9ce 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -972,6 +972,27 @@ WARNING: printf is rebound in the body of the unit to always (inherit set-flags get-flags) (set-flags (list* 'handles-events (get-flags))))) + (define out-style-name "text:ports out") + (define error-style-name "text:ports err") + (define value-style-name "text:ports value") + (let ([create-style-name + (λ (name sd) + (let* ([sl (editor:get-standard-style-list)]) + (send sl new-named-style + name + (send sl find-or-create-style + (send sl find-named-style "Standard") + sd))))]) + (let ([out-sd (make-object style-delta% 'change-nothing)]) + (send out-sd set-delta-foreground (make-object color% 150 0 150)) + (create-style-name out-style-name out-sd)) + (let ([err-sd (make-object style-delta% 'change-italic)]) + (send err-sd set-delta-foreground (make-object color% 255 0 0)) + (create-style-name error-style-name err-sd)) + (let ([value-sd (make-object style-delta% 'change-nothing)]) + (send value-sd set-delta-foreground (make-object color% 0 0 175)) + (create-style-name value-style-name value-sd))) + (define ports-mixin (mixin (wide-snip<%>) (ports<%>) (inherit begin-edit-sequence @@ -1111,18 +1132,9 @@ WARNING: printf is rebound in the body of the unit to always (define/pubment (submit-to-port? key) (inner #t submit-to-port? key)) (define/pubment (on-submit) (inner (void) on-submit)) - (define/public (get-out-style-delta) - (let ([out-sd (make-object style-delta% 'change-nothing)]) - (send out-sd set-delta-foreground (make-object color% 150 0 150)) - out-sd)) - (define/public (get-err-style-delta) - (let ([err-sd (make-object style-delta% 'change-italic)]) - (send err-sd set-delta-foreground (make-object color% 255 0 0)) - err-sd)) - (define/public (get-value-style-delta) - (let ([value-sd (make-object style-delta% 'change-nothing)]) - (send value-sd set-delta-foreground (make-object color% 0 0 175)) - value-sd)) + (define/public (get-out-style-delta) out-style-name) + (define/public (get-err-style-delta) error-style-name) + (define/public (get-value-style-delta) value-style-name) (define/public (get-box-input-editor-snip%) editor-snip%) (define/public (get-box-input-text%) input-box%) @@ -1444,12 +1456,19 @@ WARNING: printf is rebound in the body of the unit to always (let* ([add-standard (λ (sd) - (let* ([style-list (get-style-list)] - [std (send style-list find-named-style "Standard")]) - (if std - (send style-list find-or-create-style std sd) - (let ([basic (send style-list find-named-style "Basic")]) - (send style-list find-or-create-style basic sd)))))] + (cond + [(string? sd) + (let ([style-list (get-style-list)]) + (or (send style-list find-named-style sd) + (send style-list find-named-style "Standard") + (send style-list find-named-style "Basic")))] + [sd + (let* ([style-list (get-style-list)] + [std (send style-list find-named-style "Standard")]) + (if std + (send style-list find-or-create-style std sd) + (let ([basic (send style-list find-named-style "Basic")]) + (send style-list find-or-create-style basic sd))))]))] [out-style (add-standard (get-out-style-delta))] [err-style (add-standard (get-err-style-delta))] [value-style (add-standard (get-value-style-delta))]) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index b9b92c552a..1d8dfa0afa 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -474,6 +474,12 @@ please adhere to these guidelines: (add-keyword "Add") (remove-keyword "Remove") + ; repl color preferences + (repl-colors "REPL") + (repl-out-color "Output") + (repl-value-color "Values") + (repl-error-color "Errors") + ;;; find/replace (find-and-replace "Find and Replace") (find "Find")