From 6b73899730a6b2d79e7bb3f55d8cf798f60ce285 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 20 Feb 2007 16:33:47 +0000 Subject: [PATCH] added the ability to configure the repl's colors svn: r5648 original commit: 815c6669bafc3e22b83c470208b0e2805eb32e55 --- collects/framework/framework.ss | 9 ++-- collects/framework/private/color-prefs.ss | 35 ++++++++++----- collects/framework/private/text.ss | 55 +++++++++++++++-------- 3 files changed, 66 insertions(+), 33 deletions(-) diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index e4146132..52ec47a1 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 57e6921a..644eed11 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 fc630ba4..51620da9 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))])