suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added the ability to configure the repl's colors

Browse Source 
svn: r5648
This commit is contained in:
Robby Findler 2007-02-20 16:33:47 +00:00
parent 68799a5373
commit 815c6669ba
6 changed files with 111 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/drscheme/private/main.ss
View File

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

1
collects/drscheme/private/rep.ss
View File

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

9
collects/framework/framework.ss
View File

@ -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"

35
collects/framework/private/color-prefs.ss
View File

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

55
collects/framework/private/text.ss
View File

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

6
collects/string-constants/english-string-constants.ss
View File

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