- adjust the teaching language test coverage style implementation
so that it changes immediately when the black-on-white and white-on-black buttons are pushed in the preferences dialog - expanded the color preferences api a little to allow the specification of background colors in addition to the foreground/style information already there - changed the test coverage style so that the colors are settable in the preferences dialog closes PR 11704
This commit is contained in:
Robby Findler
parent
7cc3465486
commit
87e637a1cc
|
|
@ -1554,10 +1554,12 @@
|
|||
(proc-doc/names
|
||||
color-prefs:register-color-preference
|
||||
(->* (symbol? string? (or/c (is-a?/c color%) (is-a?/c style-delta%)))
|
||||
((or/c string? (is-a?/c color%) false/c))
|
||||
((or/c string? (is-a?/c color%) #f)
|
||||
#:background (or/c (is-a?/c color%) #f))
|
||||
void?)
|
||||
((pref-name style-name color/sd)
|
||||
((white-on-black-color #f)))
|
||||
((white-on-black-color #f)
|
||||
(background #f)))
|
||||
@{This function registers a color preference and initializes the style list
|
||||
returned from @scheme[editor:get-standard-style-list]. In particular, it
|
||||
calls @scheme[preferences:set-default] and
|
||||
|
|
@ -1578,7 +1580,13 @@
|
|||
If @scheme[white-on-black-color] is not @scheme[#f], then the color of the
|
||||
@scheme[color/sd] argument is used in combination with
|
||||
@scheme[white-on-black-color] to register this preference with
|
||||
@scheme[color-prefs:set-default/color-scheme].})
|
||||
@scheme[color-prefs:set-default/color-scheme].
|
||||
|
||||
If either @racket[background] is
|
||||
not @racket[#f], then it is used to construct the default background color
|
||||
for the style delta.
|
||||
|
||||
})
|
||||
|
||||
(proc-doc/names
|
||||
color-prefs:add-background-preferences-panel
|
||||
|
|
@ -1596,9 +1604,13 @@
|
|||
|
||||
(proc-doc/names
|
||||
color-prefs:build-color-selection-panel
|
||||
((is-a?/c area-container<%>) symbol? string? string? . -> . void?)
|
||||
(parent pref-sym style-name example-text)
|
||||
@{Builds a panel with a number of controls for configuring a font: the color
|
||||
(->* ((is-a?/c area-container<%>) symbol? string? string?)
|
||||
(#:background? boolean?)
|
||||
void?)
|
||||
((parent pref-sym style-name example-text)
|
||||
((background? #f)))
|
||||
@{Builds a panel with a number of controls for configuring a font: its color
|
||||
(including a background configuration if @racket[background] is @racket[#t])
|
||||
and check boxes for bold, italic, and underline. The @scheme[parent]
|
||||
argument specifies where the panel will be placed. The @scheme[pref-sym]
|
||||
should be a preference (suitable for use with @scheme[preferences:get] and
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
|
||||
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
|
||||
;; constructs a panel containg controls to configure the preferences panel.
|
||||
(define (build-color-selection-panel parent pref-sym style-name example-text)
|
||||
(define (build-color-selection-panel parent pref-sym style-name example-text #:background? [background? #f])
|
||||
(define (update-style-delta func)
|
||||
(let ([working-delta (new style-delta%)])
|
||||
(send working-delta copy (preferences:get pref-sym))
|
||||
|
|
@ -118,10 +118,12 @@
|
|||
(list-ref smoothing-options
|
||||
(send c get-selection))))))]))
|
||||
|
||||
(define color-button
|
||||
(define foreground-color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
(new button%
|
||||
[label (string-constant cs-change-color)]
|
||||
[label (if background?
|
||||
(string-constant cs-foreground-color)
|
||||
(string-constant cs-change-color))]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (color-button evt)
|
||||
|
|
@ -139,6 +141,29 @@
|
|||
(update-style-delta
|
||||
(λ (delta)
|
||||
(send delta set-delta-foreground users-choice))))))])))
|
||||
(define background-color-button
|
||||
(and (>= (get-display-depth) 8)
|
||||
background?
|
||||
(new button%
|
||||
[label (string-constant cs-background-color)]
|
||||
[parent hp]
|
||||
[callback
|
||||
(λ (color-button evt)
|
||||
(let* ([add (send (preferences:get pref-sym) get-background-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-background users-choice))))))])))
|
||||
|
||||
(define style (send (send e get-style-list) find-named-style style-name))
|
||||
|
||||
(send c set-line-count 1)
|
||||
|
|
@ -426,29 +451,33 @@
|
|||
panel))))
|
||||
|
||||
;; see docs
|
||||
(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]
|
||||
[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%)))
|
||||
(when white-on-black-color
|
||||
(set! color-scheme-colors
|
||||
(cons (list pref-name
|
||||
color/sd
|
||||
(to-color white-on-black-color))
|
||||
color-scheme-colors)))
|
||||
(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)))
|
||||
(editor:set-standard-style-list-delta style-name (preferences:get pref-name)))))
|
||||
(define (register-color-preference pref-name style-name color/sd
|
||||
[white-on-black-color #f]
|
||||
[use-old-marshalling? #t]
|
||||
#:background [background #f])
|
||||
(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)])])
|
||||
|
||||
(when background
|
||||
(send sd set-delta-background background))
|
||||
|
||||
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%)))
|
||||
(when white-on-black-color
|
||||
(set! color-scheme-colors
|
||||
(cons (list pref-name
|
||||
color/sd
|
||||
(to-color white-on-black-color))
|
||||
color-scheme-colors)))
|
||||
(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)))
|
||||
(editor:set-standard-style-list-delta style-name (preferences:get pref-name))))
|
||||
|
||||
(define color-scheme-colors '())
|
||||
|
||||
|
|
|
|||
|
|
@ -1124,63 +1124,10 @@
|
|||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(let ([on-sd (make-object style-delta%)]
|
||||
[off-sd (make-object style-delta%)])
|
||||
(cond
|
||||
[(preferences:get 'framework:white-on-black?)
|
||||
(send on-sd set-delta-foreground "white")
|
||||
(send off-sd set-delta-foreground "indianred")]
|
||||
[else
|
||||
;; picture 1.png
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send off-sd set-delta-foreground "lightgray")
|
||||
(send off-sd set-delta-background "firebrick"))
|
||||
|
||||
;; picture 2.png
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "darkgreen")
|
||||
(send off-sd set-delta-foreground "firebrick")
|
||||
(send off-sd set-delta-background "Khaki"))
|
||||
|
||||
;; picture 3.png
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "darkgreen")
|
||||
(send off-sd set-delta-foreground "Khaki")
|
||||
(send off-sd set-delta-background "black"))
|
||||
|
||||
;; picture 4.png
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send off-sd set-delta-foreground "Khaki")
|
||||
(send off-sd set-delta-background "darkblue"))
|
||||
|
||||
;; picture 5.png
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground (make-object color% 0 80 0))
|
||||
(send off-sd set-delta-foreground "orange")
|
||||
(send off-sd set-delta-background "black"))
|
||||
|
||||
;; variation on 5.
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send on-sd set-transparent-text-backing-off #f)
|
||||
(send on-sd set-transparent-text-backing-on #t)
|
||||
(send off-sd set-delta-foreground "orange")
|
||||
(send off-sd set-delta-background "black"))
|
||||
|
||||
;; mike's preferred color scheme, but looks just like the selection
|
||||
#;
|
||||
(begin
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send off-sd set-delta-background "lightblue")
|
||||
(send off-sd set-delta-foreground "black"))])
|
||||
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
|
||||
(define sl (editor:get-standard-style-list))
|
||||
(define on-s (send sl find-named-style test-coverage-on-style-name))
|
||||
(define off-s (send sl find-named-style test-coverage-off-style-name))
|
||||
(send rep set-test-coverage-info ht on-s off-s #f))))))))
|
||||
(let ([ht (thread-cell-ref current-test-coverage-info)])
|
||||
(when ht
|
||||
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
|
||||
|
|
@ -1362,4 +1309,54 @@
|
|||
(reader-module '(lib "htdp-beginner-reader.ss" "lang"))
|
||||
(stepper:supported #t)
|
||||
(stepper:enable-let-lifting #t)
|
||||
(stepper:show-lambdas-as-lambdas #f))))))
|
||||
(stepper:show-lambdas-as-lambdas #f))))
|
||||
|
||||
(define test-coverage-on-style-name "plt:htdp:test-coverage-on")
|
||||
(define test-coverage-off-style-name "plt:htdp:test-coverage-off")
|
||||
(define test-coverage-on-style-pref (string->symbol test-coverage-on-style-name))
|
||||
(define test-coverage-off-style-pref (string->symbol test-coverage-off-style-name))
|
||||
|
||||
(color-prefs:register-color-preference test-coverage-on-style-pref
|
||||
test-coverage-on-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:register-color-preference test-coverage-off-style-pref
|
||||
test-coverage-off-style-name
|
||||
(send the-color-database find-color "orange")
|
||||
(send the-color-database find-color "indianred")
|
||||
#:background (send the-color-database find-color "black"))
|
||||
(color-prefs:add-to-preferences-panel
|
||||
"HtDP Languages"
|
||||
(λ (parent)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
test-coverage-on-style-pref
|
||||
test-coverage-on-style-name
|
||||
(string-constant test-coverage-on))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
test-coverage-off-style-pref
|
||||
test-coverage-off-style-name
|
||||
(string-constant test-coverage-off)
|
||||
#:background? #t)))
|
||||
|
||||
(define (update-sds white-on-black?)
|
||||
(define sl (editor:get-standard-style-list))
|
||||
(define on-s (send sl find-named-style test-coverage-on-style-name))
|
||||
(define off-s (send sl find-named-style test-coverage-off-style-name))
|
||||
(define on-sd (make-object style-delta%))
|
||||
(define off-sd (make-object style-delta%))
|
||||
(send on-s get-delta on-sd)
|
||||
(send off-s get-delta off-sd)
|
||||
(cond
|
||||
[white-on-black?
|
||||
(send on-sd set-delta-foreground "white")
|
||||
(send off-sd set-delta-foreground "indianred")
|
||||
(send off-sd set-delta-background "black")]
|
||||
[else
|
||||
(send on-sd set-delta-foreground "black")
|
||||
(send off-sd set-delta-foreground "orange")
|
||||
(send off-sd set-delta-background "black")])
|
||||
(preferences:set test-coverage-on-style-pref on-sd)
|
||||
(preferences:set test-coverage-off-style-pref off-sd))
|
||||
|
||||
(preferences:add-callback 'framework:white-on-black?
|
||||
(λ (p v) (update-sds v)))))
|
||||
|
|
|
|||
|
|
@ -182,6 +182,8 @@ please adhere to these guidelines:
|
|||
(cs-bold "Bold")
|
||||
(cs-underline "Underline")
|
||||
(cs-change-color "Change Color")
|
||||
(cs-foreground-color "Foreground Color")
|
||||
(cs-background-color "Background Color")
|
||||
(cs-tack/untack-arrow "Tack/Untack Arrow(s)")
|
||||
(cs-jump-to-next-bound-occurrence "Jump to Next Bound Occurrence")
|
||||
(cs-jump-to-binding "Jump to Binding Occurrence")
|
||||
|
|
@ -1159,6 +1161,9 @@ please adhere to these guidelines:
|
|||
(test-coverage-clear-and-do-not-ask-again "Yes, and don't ask again")
|
||||
(test-coverage-ask? "Ask about clearing test coverage")
|
||||
|
||||
(test-coverage-on "Tests covered")
|
||||
(test-coverage-off "Tests didn't cover")
|
||||
|
||||
;; tracing
|
||||
(tracing-enable-tracing "Enable tracing")
|
||||
(tracing-show-tracing-window "Show Tracing")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user