improved color preferences; this is the change that requires people to rename their preferences as explained on plt-scheme
svn: r5996
This commit is contained in:
Robby Findler
parent
1adc10788d
commit
e5698365c9
|
|
@ -383,22 +383,22 @@
|
|||
(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)
|
||||
(make-object color% 57 89 216))
|
||||
(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)
|
||||
(make-object color% 192 46 214))
|
||||
(define repl-error-pref 'drscheme:read-eval-print-loop:error-color)
|
||||
(define repl-out-pref 'drscheme:read-eval-print-loop:out-color)
|
||||
(define repl-value-pref 'drscheme:read-eval-print-loop:value-color)
|
||||
(color-prefs:register-color-preference repl-value-pref
|
||||
"text:ports value"
|
||||
(make-object color% 0 0 175)
|
||||
(make-object color% 57 89 216))
|
||||
(color-prefs:register-color-preference 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-preference repl-out-pref
|
||||
"text:ports out"
|
||||
(make-object color% 150 0 150)
|
||||
(make-object color% 192 46 214))
|
||||
(color-prefs:add-to-preferences-panel
|
||||
(string-constant repl-colors)
|
||||
(λ (parent)
|
||||
|
|
|
|||
|
|
@ -1218,8 +1218,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(send keymap map-function "c:x;n" "jump to next bound occurrence")
|
||||
(send keymap map-function "c:x;d" "jump to definition (in other file)"))
|
||||
|
||||
(define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound-identifier)
|
||||
(define imported-variable-style-pref 'drscheme:check-syntax:imported-identifier)
|
||||
(define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound)
|
||||
(define imported-variable-style-pref 'drscheme:check-syntax:imported)
|
||||
|
||||
(define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
|
||||
(define imported-variable-style-name (symbol->string imported-variable-style-pref))
|
||||
|
|
@ -1237,14 +1237,14 @@ If the namespace does not, they are colored the unbound color.
|
|||
imported-variable-style-name
|
||||
(string-constant cs-imported-variable)))
|
||||
|
||||
(fw:color-prefs:register-color-pref lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(fw:color-prefs:register-color-pref imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
(fw:color-prefs:register-color-preference lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(fw:color-prefs:register-color-preference imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1396,7 +1396,7 @@
|
|||
"@flink preferences:set-un/marshall"
|
||||
"with appropriate arguments to register the preference.")
|
||||
|
||||
(color-prefs:register-color-pref
|
||||
(color-prefs:register-color-preference
|
||||
(opt->
|
||||
(symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
|
||||
((or/c string? (is-a?/c color%) false/c))
|
||||
|
|
@ -1461,12 +1461,12 @@
|
|||
"and \\var{example-text} is shown in the panel so users can see"
|
||||
"the results of their configuration.")
|
||||
|
||||
(color-prefs:marshall-style
|
||||
(color-prefs:marshall-style-delta
|
||||
(-> (is-a?/c style-delta%) printable/c)
|
||||
(style-delta)
|
||||
"Builds a printed representation for a style-delta.")
|
||||
|
||||
(color-prefs:unmarshall-style
|
||||
(color-prefs:unmarshall-style-delta
|
||||
(-> printable/c (or/c false/c (is-a?/c style-delta%)))
|
||||
(marshalled-style-delta)
|
||||
"Builds a style delta from its printed representation."
|
||||
|
|
|
|||
|
|
@ -27,10 +27,11 @@
|
|||
(let ([delta (preferences:get pref-sym)])
|
||||
(func delta)
|
||||
(preferences:set pref-sym delta)))])
|
||||
(define hp (new horizontal-panel%
|
||||
(parent parent)
|
||||
(style '(border))
|
||||
(stretchable-height #f)))
|
||||
(define hp (new horizontal-panel%
|
||||
[parent parent]
|
||||
[style '(border)]
|
||||
[stretchable-height #f]))
|
||||
|
||||
(define e (new (class standard-style-list-text%
|
||||
(inherit change-style get-style-list)
|
||||
(define/augment (after-insert pos offset)
|
||||
|
|
@ -41,17 +42,20 @@
|
|||
(change-style style pos (+ pos offset) #f)))
|
||||
(super-new))))
|
||||
(define c (new canvas:color%
|
||||
(parent hp)
|
||||
(editor e)
|
||||
(style '(hide-hscroll
|
||||
hide-vscroll))))
|
||||
[parent hp]
|
||||
[min-width 150]
|
||||
[editor e]
|
||||
[style '(hide-hscroll hide-vscroll)]))
|
||||
|
||||
(define (make-check name on off)
|
||||
(let* ([c (λ (check command)
|
||||
(if (send check get-value)
|
||||
(update-style-delta on)
|
||||
(update-style-delta off)))]
|
||||
[check (make-object check-box% name hp c)])
|
||||
[check (new check-box%
|
||||
[label name]
|
||||
[parent hp]
|
||||
[callback c])])
|
||||
check))
|
||||
|
||||
(define slant-check
|
||||
|
|
@ -78,26 +82,65 @@
|
|||
(λ (delta)
|
||||
(send delta set-underlined-off #f)
|
||||
(send delta set-underlined-on #f))))
|
||||
|
||||
(define smoothing-options
|
||||
'(default
|
||||
partly-smoothed
|
||||
smoothed
|
||||
unsmoothed))
|
||||
(define smoothing-option-strings
|
||||
'("Default"
|
||||
"Partly smoothed"
|
||||
"Smoothed"
|
||||
"Unsmoothed"))
|
||||
|
||||
(define (smoothing->index s)
|
||||
(let loop ([i 0]
|
||||
[l smoothing-options])
|
||||
(cond
|
||||
[(null? l)
|
||||
;; if it is something strange or it is 'base, we go with 'default (which is 0)
|
||||
0]
|
||||
[else
|
||||
(if (eq? (car l) s)
|
||||
i
|
||||
(loop (+ i 1)
|
||||
(cdr l)))])))
|
||||
|
||||
(define smoothing-menu
|
||||
(new choice%
|
||||
[label #f]
|
||||
[parent hp]
|
||||
[choices smoothing-option-strings]
|
||||
[callback
|
||||
(λ (c e)
|
||||
(update-style-delta
|
||||
(λ (delta)
|
||||
(send delta set-smoothing-on
|
||||
(list-ref smoothing-options
|
||||
(send c get-selection))))))]))
|
||||
|
||||
(define color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
(make-object button%
|
||||
(string-constant cs-change-color)
|
||||
hp
|
||||
(λ (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
(send add get-b))]
|
||||
[users-choice
|
||||
(get-color-from-user
|
||||
(format (string-constant syntax-coloring-choose-color) example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
(when users-choice
|
||||
(update-style-delta
|
||||
(λ (delta)
|
||||
(send delta set-delta-foreground users-choice)))))))))
|
||||
(new button%
|
||||
[label (string-constant cs-change-color)]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
|
||||
[color (make-object color%
|
||||
(send add get-r)
|
||||
(send add get-g)
|
||||
(send add get-b))]
|
||||
[users-choice
|
||||
(get-color-from-user
|
||||
(format (string-constant syntax-coloring-choose-color) example-text)
|
||||
(send color-button get-top-level-window)
|
||||
color)])
|
||||
(when users-choice
|
||||
(update-style-delta
|
||||
(λ (delta)
|
||||
(send delta set-delta-foreground users-choice))))))])))
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
|
|
@ -110,13 +153,15 @@
|
|||
(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 smoothing-menu set-selection (smoothing->index (send style get-smoothing)))
|
||||
(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))))
|
||||
(send underline-check set-value (send sd get-underlined-on))
|
||||
(send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
|
||||
(void)))
|
||||
|
||||
(define (add/mult-set m v)
|
||||
|
|
@ -130,45 +175,90 @@
|
|||
(map unbox (list b1 b2 b3))))
|
||||
|
||||
(define style-delta-get/set
|
||||
(list (cons (λ (x) (send x get-alignment-off))
|
||||
(λ (x v) (send x set-alignment-off v)))
|
||||
(cons (λ (x) (send x get-alignment-on))
|
||||
(λ (x v) (send x set-alignment-on v)))
|
||||
(cons (λ (x) (add/mult-get (send x get-background-add)))
|
||||
(λ (x v) (add/mult-set (send x get-background-add) v)))
|
||||
(cons (λ (x) (add/mult-get (send x get-background-mult)))
|
||||
(λ (x v) (add/mult-set (send x get-background-mult) v)))
|
||||
(cons (λ (x) (send x get-face))
|
||||
(λ (x v) (send x set-face v)))
|
||||
(cons (λ (x) (send x get-family))
|
||||
(λ (x v) (send x set-family v)))
|
||||
(cons (λ (x) (add/mult-get (send x get-foreground-add)))
|
||||
(λ (x v) (add/mult-set (send x get-foreground-add) v)))
|
||||
(cons (λ (x) (add/mult-get (send x get-foreground-mult)))
|
||||
(λ (x v) (add/mult-set (send x get-foreground-mult) v)))
|
||||
(cons (λ (x) (send x get-size-add))
|
||||
(λ (x v) (send x set-size-add v)))
|
||||
(cons (λ (x) (send x get-size-mult))
|
||||
(λ (x v) (send x set-size-mult v)))
|
||||
(cons (λ (x) (send x get-style-off))
|
||||
(λ (x v) (send x set-style-off v)))
|
||||
(cons (λ (x) (send x get-style-on))
|
||||
(λ (x v) (send x set-style-on v)))
|
||||
(cons (λ (x) (send x get-underlined-off))
|
||||
(λ (x v) (send x set-underlined-off v)))
|
||||
(cons (λ (x) (send x get-underlined-on))
|
||||
(λ (x v) (send x set-underlined-on v)))
|
||||
(cons (λ (x) (send x get-weight-off))
|
||||
(λ (x v) (send x set-weight-off v)))
|
||||
(cons (λ (x) (send x get-weight-on))
|
||||
(λ (x v) (send x set-weight-on v)))))
|
||||
(let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))])
|
||||
(list (list (λ (x) (send x get-alignment-off))
|
||||
(λ (x v) (send x set-alignment-off v))
|
||||
(λ (x) (memq x '(base top center bottom))))
|
||||
|
||||
(list (λ (x) (send x get-alignment-on))
|
||||
(λ (x v) (send x set-alignment-on v))
|
||||
(λ (x) (memq x '(base top center bottom))))
|
||||
|
||||
(list (λ (x) (add/mult-get (send x get-background-add)))
|
||||
(λ (x v) (add/mult-set (send x get-background-add) v))
|
||||
lo3n)
|
||||
|
||||
(list (λ (x) (add/mult-get (send x get-background-mult)))
|
||||
(λ (x v) (add/mult-set (send x get-background-mult) v))
|
||||
lo3n)
|
||||
|
||||
(list (λ (x) (send x get-face))
|
||||
(λ (x v) (send x set-face v))
|
||||
(λ (x) (or (string? x) (not x))))
|
||||
|
||||
(list (λ (x) (send x get-family))
|
||||
(λ (x v) (send x set-family v))
|
||||
(λ (x) (memq x '(base default decorative roman script swiss modern symbol system))))
|
||||
|
||||
(list (λ (x) (add/mult-get (send x get-foreground-add)))
|
||||
(λ (x v) (add/mult-set (send x get-foreground-add) v))
|
||||
lo3n)
|
||||
|
||||
(list (λ (x) (add/mult-get (send x get-foreground-mult)))
|
||||
(λ (x v) (add/mult-set (send x get-foreground-mult) v))
|
||||
lo3n)
|
||||
|
||||
(list (λ (x) (send x get-size-add))
|
||||
(λ (x v) (send x set-size-add v))
|
||||
(λ (x) (and (integer? x) (exact? x) (<= 0 x 255))))
|
||||
|
||||
(list (λ (x) (send x get-size-mult))
|
||||
(λ (x v) (send x set-size-mult v))
|
||||
(λ (x) (and (number? x) (real? x))))
|
||||
|
||||
(list (λ (x) (send x get-style-off))
|
||||
(λ (x v) (send x set-style-off v))
|
||||
(λ (x) (memq x '(base normal italic slant))))
|
||||
|
||||
(list (λ (x) (send x get-style-on))
|
||||
(λ (x v) (send x set-style-on v))
|
||||
(λ (x) (memq x '(base normal italic slant))))
|
||||
|
||||
(list (λ (x) (send x get-underlined-off))
|
||||
(λ (x v) (send x set-underlined-off v))
|
||||
boolean?)
|
||||
|
||||
(list (λ (x) (send x get-underlined-on))
|
||||
(λ (x v) (send x set-underlined-on v))
|
||||
boolean?)
|
||||
|
||||
(list (λ (x) (send x get-weight-off))
|
||||
(λ (x v) (send x set-weight-off v))
|
||||
(λ (x) (memq x '(base normal bold light))))
|
||||
|
||||
(list (λ (x) (send x get-weight-on))
|
||||
(λ (x v) (send x set-weight-on v))
|
||||
(λ (x) (memq x '(base normal bold light)))))))
|
||||
|
||||
(define (marshall-style style)
|
||||
(define (marshall-style-delta style)
|
||||
(map (λ (fs) ((car fs) style)) style-delta-get/set))
|
||||
|
||||
(define (unmarshall-style info)
|
||||
(define (unmarshall-style-delta info)
|
||||
(let ([style (make-object style-delta%)])
|
||||
(for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
|
||||
|
||||
(when (list? info)
|
||||
(let loop ([style-delta-get/set style-delta-get/set]
|
||||
[info info])
|
||||
(cond
|
||||
[(null? info) (void)]
|
||||
[(null? style-delta-get/set) (void)]
|
||||
[else (let ([v (car info)]
|
||||
[fs (car style-delta-get/set)])
|
||||
(when ((list-ref fs 2) v)
|
||||
((list-ref fs 1) style v))
|
||||
(loop (cdr style-delta-get/set)
|
||||
(cdr info)))])))
|
||||
|
||||
style))
|
||||
|
||||
(define (make-style-delta color bold? underline? italic?)
|
||||
|
|
@ -306,8 +396,10 @@
|
|||
panel))))
|
||||
|
||||
;; see docs
|
||||
(define register-color-pref
|
||||
(opt-lambda (pref-name style-name color/sd [white-on-black-color #f])
|
||||
(define register-color-preference
|
||||
(opt-lambda (pref-name style-name color/sd
|
||||
[white-on-black-color #f]
|
||||
[use-old-marshalling? #t])
|
||||
(let ([sd (cond
|
||||
[(is-a? color/sd style-delta%)
|
||||
color/sd]
|
||||
|
|
@ -322,7 +414,7 @@
|
|||
color/sd
|
||||
(to-color white-on-black-color))
|
||||
color-scheme-colors)))
|
||||
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
|
||||
(preferences:set-un/marshall pref-name marshall-style-delta unmarshall-style-delta)
|
||||
(preferences:add-callback pref-name
|
||||
(λ (sym v)
|
||||
(editor:set-standard-style-list-delta style-name v)))
|
||||
|
|
|
|||
|
|
@ -255,10 +255,11 @@
|
|||
(let ([sym (car line)]
|
||||
[color (cadr line)]
|
||||
[white-on-black-color (cadr white-on-black-line)])
|
||||
(color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
|
||||
(scheme:short-sym->style-name sym)
|
||||
color
|
||||
white-on-black-color)))
|
||||
(color-prefs:register-color-preference
|
||||
(scheme:short-sym->pref-name sym)
|
||||
(scheme:short-sym->style-name sym)
|
||||
color
|
||||
white-on-black-color)))
|
||||
(scheme:get-color-prefs-table)
|
||||
(scheme:get-white-on-black-color-prefs-table))
|
||||
(preferences:set-default 'framework:coloring-active #t boolean?)
|
||||
|
|
|
|||
|
|
@ -310,7 +310,8 @@
|
|||
(define (short-sym->style-name sym)
|
||||
(hash-table-get sn-hash sym
|
||||
(λ ()
|
||||
(let ([s (format "framework:syntax-coloring:scheme:~a" (xlate-sym-style sym))])
|
||||
(let ([s (format "framework:syntax-color:scheme:~a"
|
||||
(xlate-sym-style sym))])
|
||||
(hash-table-put! sn-hash sym s)
|
||||
s))))
|
||||
|
||||
|
|
|
|||
|
|
@ -364,12 +364,12 @@
|
|||
(define-signature color-prefs-class^
|
||||
())
|
||||
(define-signature color-prefs^ extends color-prefs-class^
|
||||
(register-color-pref
|
||||
(register-color-preference
|
||||
add-to-preferences-panel
|
||||
build-color-selection-panel
|
||||
add-background-preferences-panel
|
||||
marshall-style
|
||||
unmarshall-style
|
||||
marshall-style-delta
|
||||
unmarshall-style-delta
|
||||
set-default/color-scheme))
|
||||
|
||||
(define-signature scheme-class^
|
||||
|
|
|
|||
|
|
@ -45,8 +45,8 @@
|
|||
|
||||
;; short-sym->style-name : symbol->string
|
||||
;; converts the short name (from the table above) into a name in the editor list
|
||||
;; (they are added in by `color-prefs:register-color-pref', called below)
|
||||
(define (short-sym->style-name sym) (format "profj:syntax-coloring:scheme:~a" sym))
|
||||
;; (they are added in by `color-prefs:register-color-preference', called below)
|
||||
(define (short-sym->style-name sym) (format "profj:syntax-colors:scheme:~a" sym))
|
||||
|
||||
;; extend-preferences-panel : vertical-panel -> void
|
||||
;; adds in the configuration for the Java colors to the prefs panel
|
||||
|
|
@ -768,9 +768,9 @@
|
|||
(define (register line)
|
||||
(let ([sym (car line)]
|
||||
[color (cadr line)])
|
||||
(color-prefs:register-color-pref (short-sym->pref-name sym)
|
||||
(short-sym->style-name sym)
|
||||
color)))
|
||||
(color-prefs:register-color-preference (short-sym->pref-name sym)
|
||||
(short-sym->style-name sym)
|
||||
color)))
|
||||
(for-each register color-prefs-table)
|
||||
(for-each register coverage-color-prefs)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,22 @@
|
|||
Version 370
|
||||
------------------------------
|
||||
|
||||
. changed the save format for color preferences. Due to a
|
||||
bug in earlier versions, this means that color
|
||||
preferences saved in earlier versions of DrScheme will
|
||||
not be copied forward to this version.
|
||||
|
||||
These functions are renamed:
|
||||
|
||||
color-prefs:marshall-style => color-prefs:marshall-style-delta
|
||||
color-prefs:unmarshall-style => color-prefs:unmarshall-style-delta
|
||||
color-prefs:register-color-pref => color-prefs:register-color-preference
|
||||
|
||||
If you used those functions before, do not use the new
|
||||
ones with the same preference symbol as you used in old
|
||||
versions, or else the old version of your app (or
|
||||
drscheme) will fail to start up.
|
||||
|
||||
. changed the frame:editor-mixin, frame:text-mixin and
|
||||
frame:pasteboard-mixin slightly so that one can supply
|
||||
the editor class as an initialization argument
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user