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

fixed PR 9409

Browse Source 
svn: r9959
This commit is contained in:
Robby Findler 2008-05-26 15:19:27 +00:00
parent c9bf30746e
commit 613527fd25
2 changed files with 178 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/framework/preferences.ss
View File

@ -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" "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
p value)) p value))
(check-callbacks p value) (check-callbacks p value)
(hash-set! preferences p value) (hash-set! preferences p value))]
(void))]
[(not (pref-default-set? p)) [(not (pref-default-set? p))
(raise-unknown-preference-error (raise-unknown-preference-error
'preferences:set "tried to set the preference ~e to ~e, but no default is set" '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)) (map (λ (p value) (marshall-pref p value))
ps ps
values)) values))
(void)) (void))
(define preferences:low-level-put-preferences (make-parameter put-preferences)) (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)) (string-append (format "~a: " sym) (apply format fmt args))
(current-continuation-marks)))) (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 ;; add-callback : sym (-> void) -> void
(define preferences:add-callback (define preferences:add-callback
(lambda (p callback [weak? #f]) (lambda (p callback [weak? #f])
@ -287,11 +273,40 @@ the state transitions / contracts are:
(hash-ref marshall-unmarshall p (λ () (k value))))]) (hash-ref marshall-unmarshall p (λ () (k value))))])
(marshaller 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-struct preferences:snapshot (x))
(define snapshot-grabbed? #f) (define snapshot-grabbed? #f)
(define (preferences:get-prefs-snapshot) (define (preferences:get-prefs-snapshot)
(set! snapshot-grabbed? #t) (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) (define (preferences:restore-prefs-snapshot snapshot)
(multi-set (map car (preferences:snapshot-x 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 restores the users's configuration to the
default preferences.}) default preferences.})
(proc-doc/names (proc-doc/names
exn:make-unknown-preference exn:make-unknown-preference
(string? continuation-mark-set? . -> . exn:unknown-preference?) (string? continuation-mark-set? . -> . exn:unknown-preference?)
@ -462,6 +475,9 @@ the state transitions / contracts are:
(-> preferences:snapshot?) (-> preferences:snapshot?)
() ()
@{Caches all of the current values of the preferences and returns them. @{Caches all of the current values of the preferences and returns them.
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 See also @scheme[preferences:restore-prefs-snapshot].}))
@scheme[preferences:restore-prefs-snapshot].}))

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

@ -19,155 +19,148 @@
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void ;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
;; constructs a panel containg controls to configure the preferences panel. ;; constructs a panel containg controls to configure the preferences panel.
(define build-color-selection-panel (define (build-color-selection-panel parent pref-sym style-name example-text)
(opt-lambda (parent (define (update-style-delta func)
pref-sym (let ([working-delta (new style-delta%)])
style-name (send working-delta copy (preferences:get pref-sym))
example-text)
(define (update-style-delta func)
(func working-delta) (func working-delta)
(let ([nd (new style-delta%)]) (preferences:set pref-sym working-delta)))
(send nd copy working-delta) (define hp (new horizontal-panel%
(preferences:set pref-sym nd))) [parent parent]
(define working-delta (let ([sd (new style-delta%)]) [style '(border)]
(send sd copy (preferences:get pref-sym)) [stretchable-height #f]))
sd))
(define hp (new horizontal-panel%
[parent parent]
[style '(border)]
[stretchable-height #f]))
(define e (new (class standard-style-list-text% (define e (new (class standard-style-list-text%
(inherit change-style get-style-list) (inherit change-style get-style-list)
(define/augment (after-insert pos offset) (define/augment (after-insert pos offset)
(inner (void) after-insert pos offset) (inner (void) after-insert pos offset)
(let ([style (send (get-style-list) (let ([style (send (get-style-list)
find-named-style find-named-style
style-name)]) style-name)])
(change-style style pos (+ pos offset) #f))) (change-style style pos (+ pos offset) #f)))
(super-new)))) (super-new))))
(define c (new canvas:color% (define c (new canvas:color%
[parent hp] [parent hp]
[min-width 150] [min-width 150]
[editor e] [editor e]
[style '(hide-hscroll hide-vscroll)])) [style '(hide-hscroll hide-vscroll)]))
(define (make-check name on off) (define (make-check name on off)
(let* ([c (λ (check command) (let* ([c (λ (check command)
(if (send check get-value) (if (send check get-value)
(update-style-delta on) (update-style-delta on)
(update-style-delta off)))] (update-style-delta off)))]
[check (new check-box% [check (new check-box%
[label name] [label name]
[parent hp] [parent hp]
[callback c])]) [callback c])])
check)) check))
(define slant-check (define slant-check
(make-check (string-constant cs-italic) (make-check (string-constant cs-italic)
(λ (delta) (λ (delta)
(send delta set-style-on 'italic) (send delta set-style-on 'italic)
(send delta set-style-off 'base)) (send delta set-style-off 'base))
(λ (delta) (λ (delta)
(send delta set-style-on 'normal) (send delta set-style-on 'normal)
(send delta set-style-off 'base)))) (send delta set-style-off 'base))))
(define bold-check (define bold-check
(make-check (string-constant cs-bold) (make-check (string-constant cs-bold)
(λ (delta) (λ (delta)
(send delta set-weight-on 'bold) (send delta set-weight-on 'bold)
(send delta set-weight-off 'base)) (send delta set-weight-off 'base))
(λ (delta) (λ (delta)
(send delta set-weight-on 'normal) (send delta set-weight-on 'normal)
(send delta set-weight-off 'base)))) (send delta set-weight-off 'base))))
(define underline-check (define underline-check
(make-check (string-constant cs-underline) (make-check (string-constant cs-underline)
(λ (delta) (λ (delta)
(send delta set-underlined-on #t) (send delta set-underlined-on #t)
(send delta set-underlined-off #f)) (send delta set-underlined-off #f))
(λ (delta) (λ (delta)
(send delta set-underlined-off #f) (send delta set-underlined-off #f)
(send delta set-underlined-on #f)))) (send delta set-underlined-on #f))))
(define smoothing-options (define smoothing-options
'(default '(default
partly-smoothed partly-smoothed
smoothed smoothed
unsmoothed)) unsmoothed))
(define smoothing-option-strings (define smoothing-option-strings
'("Default" '("Default"
"Partly smoothed" "Partly smoothed"
"Smoothed" "Smoothed"
"Unsmoothed")) "Unsmoothed"))
(define (smoothing->index s) (define (smoothing->index s)
(let loop ([i 0] (let loop ([i 0]
[l smoothing-options]) [l smoothing-options])
(cond (cond
[(null? l) [(null? l)
;; if it is something strange or it is 'base, we go with 'default (which is 0) ;; if it is something strange or it is 'base, we go with 'default (which is 0)
0] 0]
[else [else
(if (eq? (car l) s) (if (eq? (car l) s)
i i
(loop (+ i 1) (loop (+ i 1)
(cdr l)))]))) (cdr l)))])))
(define smoothing-menu (define smoothing-menu
(new choice% (new choice%
[label #f] [label #f]
[parent hp] [parent hp]
[choices smoothing-option-strings] [choices smoothing-option-strings]
[callback [callback
(λ (c e) (λ (c e)
(update-style-delta (update-style-delta
(λ (delta) (λ (delta)
(send delta set-smoothing-on (send delta set-smoothing-on
(list-ref smoothing-options (list-ref smoothing-options
(send c get-selection))))))])) (send c get-selection))))))]))
(define color-button (define color-button
(and (>= (get-display-depth) 8) (and (>= (get-display-depth) 8)
(new button% (new button%
[label (string-constant cs-change-color)] [label (string-constant cs-change-color)]
[parent hp] [parent hp]
[callback [callback
(λ (color-button evt) (λ (color-button evt)
(let* ([add (send (preferences:get pref-sym) get-foreground-add)] (let* ([add (send (preferences:get pref-sym) get-foreground-add)]
[color (make-object color% [color (make-object color%
(send add get-r) (send add get-r)
(send add get-g) (send add get-g)
(send add get-b))] (send add get-b))]
[users-choice [users-choice
(get-color-from-user (get-color-from-user
(format (string-constant syntax-coloring-choose-color) example-text) (format (string-constant syntax-coloring-choose-color) example-text)
(send color-button get-top-level-window) (send color-button get-top-level-window)
color)]) color)])
(when users-choice (when users-choice
(update-style-delta (update-style-delta
(λ (delta) (λ (delta)
(send delta set-delta-foreground users-choice))))))]))) (send delta set-delta-foreground users-choice))))))])))
(define style (send (send e get-style-list) find-named-style style-name)) (define style (send (send e get-style-list) find-named-style style-name))
(send c set-line-count 1) (send c set-line-count 1)
(send c allow-tab-exit #t) (send c allow-tab-exit #t)
(send e insert example-text) (send e insert example-text)
(send e set-position 0) (send e set-position 0)
(send slant-check set-value (or (eq? (send style get-style) 'slant) (send slant-check set-value (or (eq? (send style get-style) 'slant)
(eq? (send style get-style) 'italic))) (eq? (send style get-style) 'italic)))
(send bold-check set-value (eq? (send style get-weight) 'bold)) (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))
(send smoothing-menu set-selection (smoothing->index (send style get-smoothing))) (send smoothing-menu set-selection (smoothing->index (send style get-smoothing)))
(preferences:add-callback (preferences:add-callback
pref-sym pref-sym
(λ (p sd) (λ (p sd)
(send slant-check set-value (or (eq? (send style get-style) 'slant) (send slant-check set-value (or (eq? (send style get-style) 'slant)
(eq? (send style get-style) 'italic))) (eq? (send style get-style) 'italic)))
(send bold-check set-value (eq? (send sd get-weight-on) 'bold)) (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))))) (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on)))))
(void))) (void))
(define (add/mult-set m v) (define (add/mult-set m v)
(send m set (car v) (cadr v) (caddr v))) (send m set (car v) (cadr v) (caddr v)))