From 621d1d5ae3bb89ce283ce4c866bfb046cd78734c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 17 Feb 2011 09:30:28 -0600 Subject: [PATCH] - 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 original commit: 87e637a1ccdc3b2c6f2b9f5fc12804020dbb8a5e --- collects/framework/main.rkt | 24 +++++-- collects/framework/private/color-prefs.rkt | 81 +++++++++++++++------- 2 files changed, 73 insertions(+), 32 deletions(-) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 82b15b12..a5e2cacf 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -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 diff --git a/collects/framework/private/color-prefs.rkt b/collects/framework/private/color-prefs.rkt index 1b5319d4..957b4aba 100644 --- a/collects/framework/private/color-prefs.rkt +++ b/collects/framework/private/color-prefs.rkt @@ -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 '())