From 613527fd2573dbbe7d132912e26fa2d6896a5622 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 26 May 2008 15:19:27 +0000 Subject: [PATCH] fixed PR 9409 svn: r9959 --- collects/framework/preferences.ss | 58 +++-- collects/framework/private/color-prefs.ss | 289 +++++++++++----------- 2 files changed, 178 insertions(+), 169 deletions(-) diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss index 0994e818e1..0671752af2 100644 --- a/collects/framework/preferences.ss +++ b/collects/framework/preferences.ss @@ -141,8 +141,7 @@ the state transitions / contracts are: "tried to set preference ~e to ~e but it does not meet test from preferences:set-default" p value)) (check-callbacks p value) - (hash-set! preferences p value) - (void))] + (hash-set! preferences p value))] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:set "tried to set the preference ~e to ~e, but no default is set" @@ -154,7 +153,6 @@ the state transitions / contracts are: (map (λ (p value) (marshall-pref p value)) ps values)) - (void)) (define preferences:low-level-put-preferences (make-parameter put-preferences)) @@ -164,18 +162,6 @@ the state transitions / contracts are: (string-append (format "~a: " sym) (apply format fmt args)) (current-continuation-marks)))) -;; unmarshall-pref : symbol marshalled -> any -;; unmarshalls a preference read from the disk -(define (unmarshall-pref p data) - (let* ([un/marshall (hash-ref marshall-unmarshall p #f)] - [result (if un/marshall - ((un/marshall-unmarshall un/marshall) data) - data)] - [default (hash-ref defaults p)]) - (if ((default-checker default) result) - result - (default-value default)))) - ;; add-callback : sym (-> void) -> void (define preferences:add-callback (lambda (p callback [weak? #f]) @@ -287,11 +273,40 @@ the state transitions / contracts are: (hash-ref marshall-unmarshall p (λ () (k value))))]) (marshaller value)))) +;; unmarshall-pref : symbol marshalled -> any +;; unmarshalls a preference read from the disk +(define (unmarshall-pref p data) + (let* ([un/marshall (hash-ref marshall-unmarshall p #f)] + [result (if un/marshall + ((un/marshall-unmarshall un/marshall) data) + data)] + [default (hash-ref defaults p)]) + (if ((default-checker default) result) + result + (default-value default)))) + +;; copy-pref-value : sym any -> any +;; uses the marshalling code to copy a preference. If there +;; is not marshaller set, then no copying happens. +(define (copy-pref-value p value) + (let/ec k + (let* ([un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))] + [default (hash-ref defaults p)] + [marsh (un/marshall-marshall un/marshaller)] + [unmarsh (un/marshall-unmarshall un/marshaller)] + [marshalled (marsh value)] + [copy (unmarsh marshalled)]) + (if ((default-checker default) copy) + copy + value)))) + (define-struct preferences:snapshot (x)) (define snapshot-grabbed? #f) (define (preferences:get-prefs-snapshot) (set! snapshot-grabbed? #t) - (make-preferences:snapshot (hash-map defaults (λ (k v) (cons k (preferences:get k)))))) + (make-preferences:snapshot + (hash-map defaults + (λ (k v) (cons k (copy-pref-value k (preferences:get k))))))) (define (preferences:restore-prefs-snapshot snapshot) (multi-set (map car (preferences:snapshot-x snapshot)) @@ -418,8 +433,6 @@ the state transitions / contracts are: restores the users's configuration to the default preferences.}) - - (proc-doc/names exn:make-unknown-preference (string? continuation-mark-set? . -> . exn:unknown-preference?) @@ -462,6 +475,9 @@ the state transitions / contracts are: (-> preferences:snapshot?) () @{Caches all of the current values of the preferences and returns them. - - See also - @scheme[preferences:restore-prefs-snapshot].})) + For any preference that has marshalling and unmarshalling set + (see @scheme[preferences:set-un/marshall]), the preference value is + copied by passing it thru the marshalling and unmarshalling process. + Other values are not copied, but references to them are instead saved. + + See also @scheme[preferences:restore-prefs-snapshot].})) diff --git a/collects/framework/private/color-prefs.ss b/collects/framework/private/color-prefs.ss index decde769f5..668a8e643e 100644 --- a/collects/framework/private/color-prefs.ss +++ b/collects/framework/private/color-prefs.ss @@ -19,155 +19,148 @@ ;; 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 - (opt-lambda (parent - pref-sym - style-name - example-text) - (define (update-style-delta func) + (define (build-color-selection-panel parent pref-sym style-name example-text) + (define (update-style-delta func) + (let ([working-delta (new style-delta%)]) + (send working-delta copy (preferences:get pref-sym)) (func working-delta) - (let ([nd (new style-delta%)]) - (send nd copy working-delta) - (preferences:set pref-sym nd))) - (define working-delta (let ([sd (new style-delta%)]) - (send sd copy (preferences:get pref-sym)) - sd)) - (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) - (inner (void) after-insert pos offset) - (let ([style (send (get-style-list) - find-named-style - style-name)]) - (change-style style pos (+ pos offset) #f))) - (super-new)))) - (define c (new canvas:color% - [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 (new check-box% - [label name] - [parent hp] - [callback c])]) - check)) - - (define slant-check - (make-check (string-constant cs-italic) - (λ (delta) - (send delta set-style-on 'italic) - (send delta set-style-off 'base)) - (λ (delta) - (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 '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 #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) - (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) - (send c allow-tab-exit #t) - - (send e insert example-text) - (send e set-position 0) - - (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 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 smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on))))) - (void))) + (preferences:set pref-sym working-delta))) + (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) + (inner (void) after-insert pos offset) + (let ([style (send (get-style-list) + find-named-style + style-name)]) + (change-style style pos (+ pos offset) #f))) + (super-new)))) + (define c (new canvas:color% + [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 (new check-box% + [label name] + [parent hp] + [callback c])]) + check)) + + (define slant-check + (make-check (string-constant cs-italic) + (λ (delta) + (send delta set-style-on 'italic) + (send delta set-style-off 'base)) + (λ (delta) + (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 '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 #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) + (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) + (send c allow-tab-exit #t) + + (send e insert example-text) + (send e set-position 0) + + (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 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 smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on))))) + (void)) (define (add/mult-set m v) (send m set (car v) (cadr v) (caddr v)))