diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 2f5b14e3..9637c1bf 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -44,11 +44,12 @@ the state transitions / contracts are: [prefix frame: framework:frame^]) (export framework:preferences^) - (define pref-debug? (getenv "PLTDRPREFDEBUG")) - (when pref-debug? - (printf "PLTDRPREFDEBUG: showing get and set calls\n")) - - (define main-preferences-symbol 'plt:framework-prefs) + (define old-preferences-symbol 'plt:framework-prefs) + (define old-preferences (make-hash-table)) + (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))]) + (for-each + (λ (line) (hash-table-put! old-preferences (car line) (cadr line))) + old-prefs)) (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p))) @@ -95,15 +96,29 @@ the state transitions / contracts are: ;; return the current value of the preference `p' ;; exported (define (get p) - (when pref-debug? - (printf "get ~s\n" p)) (cond [(pref-default-set? p) - (let* ([g (gensym)] - [pref (get-preference (add-pref-prefix p) (λ () g))]) - (if (eq? g pref) - (default-value (hash-table-get defaults p)) - (unmarshall p pref)))] + + ;; unmarshall, if required + (when (hash-table-bound? marshalled p) + (hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p))) + (hash-table-remove! marshalled p)) + + ;; if there is no value in the preferences table, but there is one + ;; in the old version preferences file, take that: + (unless (hash-table-bound? preferences p) + (when (hash-table-bound? old-preferences p) + (hash-table-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p))))) + + ;; clear the pref from the old table (just in case it was taking space -- we don't need it anymore) + (when (hash-table-bound? old-preferences p) + (hash-table-remove! old-preferences p)) + + ;; if it still isn't set, take the default value + (unless (hash-table-bound? preferences p) + (hash-table-put! preferences p (default-value (hash-table-get defaults p)))) + + (hash-table-get preferences p)] [(not (pref-default-set? p)) (raise-unknown-preference-error 'preferences:get @@ -113,10 +128,7 @@ the state transitions / contracts are: ;; set : symbol any -> void ;; updates the preference ;; exported - (define (set p value) - (when pref-debug? - (printf "set ~s\n" p)) - (multi-set (list p) (list value))) + (define (set p value) (multi-set (list p) (list value))) ;; set : symbol any -> void ;; updates the preference @@ -133,6 +145,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-table-put! preferences p value) (void))] [(not (pref-default-set? p)) (raise-unknown-preference-error @@ -142,7 +155,7 @@ the state transitions / contracts are: ps values) (put-preferences/gui (map add-pref-prefix ps) - (map (λ (p value) (cadr (marshall-pref p value))) + (map (λ (p value) (marshall-pref p value)) ps values)) @@ -188,9 +201,9 @@ the state transitions / contracts are: (string->immutable-string (string-append (format "~a: " sym) (apply format fmt args))) (current-continuation-marks)))) - ;; unmarshall : symbol marshalled -> any + ;; unmarshall-pref : symbol marshalled -> any ;; unmarshalls a preference read from the disk - (define (unmarshall p data) + (define (unmarshall-pref p data) (let/ec k (let* ([unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall @@ -274,11 +287,10 @@ the state transitions / contracts are: (hash-table-get ht s (λ () (k #f))) #t)) - (define restore-defaults - (λ () - (hash-table-for-each - defaults - (λ (p v) (set p v))))) + (define (restore-defaults) + (hash-table-for-each + defaults + (λ (p def) (set p (default-value def))))) ;; set-default : (sym TST (TST -> boolean) -> void (define (set-default p default-value checker) @@ -289,7 +301,12 @@ the state transitions / contracts are: (unless default-okay? (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" p checker default-okay? default-value)) - (hash-table-put! defaults p (make-default default-value checker)))] + (hash-table-put! defaults p (make-default default-value checker)) + (let/ec k + (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))]) + ;; if there is no preference saved, we just don't do anything. + ;; `get' notices this case. + (hash-table-put! marshalled p m))))] [(not (pref-can-init? p)) (error 'preferences:set-default "tried to call set-default for preference ~e but it cannot be configured any more" @@ -306,10 +323,8 @@ the state transitions / contracts are: (let/ec k (let* ([marshaller (un/marshall-marshall - (hash-table-get marshall-unmarshall p - (λ () (k (list p value)))))] - [marshalled (marshaller value)]) - (list p marshalled)))) + (hash-table-get marshall-unmarshall p (λ () (k value))))]) + (marshaller value)))) (define (read-err input msg) (message-box diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 830ac63f..871ad8a3 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1534,126 +1534,134 @@ main-panel) - (define (make-indenting-prefs-panel p) - (define get-keywords - (λ (hash-table) - (letrec ([all-keywords (hash-table-map hash-table list)] - [pick-out (λ (wanted in out) - (cond - [(null? in) (sort out string<=?)] - [else (if (eq? wanted (cadr (car in))) - (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) - (pick-out wanted (cdr in) out))]))]) - (values (pick-out 'begin all-keywords null) - (pick-out 'define all-keywords null) - (pick-out 'lambda all-keywords null))))) - (define-values (begin-keywords define-keywords lambda-keywords) - (get-keywords (car (preferences:get 'framework:tabify)))) - (define add-button-callback - (λ (keyword-type keyword-symbol list-box) - (λ (button command) - (let ([new-one - (keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (format (string-constant enter-new-keyword) keyword-type) - (format (string-constant x-keyword) keyword-type))))]) - (when new-one - (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) - (read (open-input-string new-one)))]) - (cond - [(and (symbol? parsed) - (hash-table-get (car (preferences:get 'framework:tabify)) - parsed - (λ () #f))) - (message-box (string-constant error) - (format (string-constant already-used-keyword) parsed))] - [(symbol? parsed) - (let ([ht (car (preferences:get 'framework:tabify))]) - (hash-table-put! ht parsed keyword-symbol) - (update-list-boxes ht))] - [else (message-box - (string-constant error) - (format (string-constant expected-a-symbol) new-one))]))))))) - (define delete-callback - (λ (list-box) - (λ (button command) - (let* ([selections (send list-box get-selections)] - [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)]) - (for-each (λ (x) (send list-box delete x)) (reverse selections)) - (let ([ht (car (preferences:get 'framework:tabify))]) - (for-each (λ (x) (hash-table-remove! ht x)) symbols)))))) - (define main-panel (make-object horizontal-panel% p)) - (define make-column - (λ (string symbol keywords bang-regexp) - (let* ([vert (make-object vertical-panel% main-panel)] - [_ (make-object message% (format (string-constant x-like-keywords) string) vert)] - [box (make-object list-box% #f keywords vert void '(multiple))] - [button-panel (make-object horizontal-panel% vert)] - [text (new text-field% - (label (string-constant indenting-prefs-extra-regexp)) - (callback (λ (tf evt) - (let ([str (send tf get-value)]) - (cond - [(equal? str "") - (bang-regexp #f)] - [else - (with-handlers ([exn:fail? - (λ (x) - (color-yellow (send tf get-editor)))]) - (bang-regexp (regexp str)) - (clear-color (send tf get-editor)))])))) - (parent vert))] - [add-button (make-object button% (string-constant add-keyword) - button-panel (add-button-callback string symbol box))] - [delete-button (make-object button% (string-constant remove-keyword) - button-panel (delete-callback box))]) - (send* button-panel - (set-alignment 'center 'center) - (stretchable-height #f)) - (send add-button min-width (send delete-button get-width)) - (values box text)))) - (define (color-yellow text) - (let ([sd (make-object style-delta%)]) - (send sd set-delta-background "yellow") - (send text change-style sd 0 (send text last-position)))) - (define (clear-color text) - (let ([sd (make-object style-delta%)]) - (send sd set-delta-background "white") - (send text change-style sd 0 (send text last-position)))) - (define-values (begin-list-box begin-regexp-text) - (make-column "Begin" - 'begin - begin-keywords - (λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x)))) - (define-values (define-list-box define-regexp-text) - (make-column "Define" - 'define - define-keywords - (λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x)))) - (define-values (lambda-list-box lambda-regexp-text) - (make-column "Lambda" - 'lambda - lambda-keywords - (λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x)))) - (define update-list-boxes - (λ (hash-table) - (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] - [(reset) (λ (list-box keywords) - (send list-box clear) - (for-each (λ (x) (send list-box append x)) keywords))]) - (reset begin-list-box begin-keywords) - (reset define-list-box define-keywords) - (reset lambda-list-box lambda-keywords) - #t))) - (define update-gui - (λ (pref) - (update-list-boxes (car pref)) - (send begin-regexp-text set-value (or (object-name (cadr pref)) "")) - (send define-regexp-text set-value (or (object-name (caddr pref)) "")) - (send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) - (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) - main-panel) + (define (make-indenting-prefs-panel p) + (define get-keywords + (λ (hash-table) + (letrec ([all-keywords (hash-table-map hash-table list)] + [pick-out (λ (wanted in out) + (cond + [(null? in) (sort out string<=?)] + [else (if (eq? wanted (cadr (car in))) + (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) + (pick-out wanted (cdr in) out))]))]) + (values (pick-out 'begin all-keywords null) + (pick-out 'define all-keywords null) + (pick-out 'lambda all-keywords null))))) + (define-values (begin-keywords define-keywords lambda-keywords) + (get-keywords (car (preferences:get 'framework:tabify)))) + (define add-button-callback + (λ (keyword-type keyword-symbol list-box) + (λ (button command) + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) keyword-type) + (format (string-constant x-keyword) keyword-type))))]) + (when new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) + (cond + [(and (symbol? parsed) + (hash-table-get (car (preferences:get 'framework:tabify)) + parsed + (λ () #f))) + (message-box (string-constant error) + (format (string-constant already-used-keyword) parsed))] + [(symbol? parsed) + (let* ([pref (preferences:get 'framework:tabify)] + [ht (car pref)]) + (hash-table-put! ht parsed keyword-symbol) + (preferences:set 'framework:tabify pref) + (update-list-boxes ht))] + [else (message-box + (string-constant error) + (format (string-constant expected-a-symbol) new-one))]))))))) + (define delete-callback + (λ (list-box) + (λ (button command) + (let* ([selections (send list-box get-selections)] + [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)]) + (for-each (λ (x) (send list-box delete x)) (reverse selections)) + (let* ([pref (preferences:get 'framework:tabify)] + [ht (car pref)]) + (for-each (λ (x) (hash-table-remove! ht x)) symbols) + (preferences:set 'framework:tabify pref)))))) + (define main-panel (make-object horizontal-panel% p)) + (define make-column + (λ (string symbol keywords bang-regexp) + (let* ([vert (make-object vertical-panel% main-panel)] + [_ (make-object message% (format (string-constant x-like-keywords) string) vert)] + [box (make-object list-box% #f keywords vert void '(multiple))] + [button-panel (make-object horizontal-panel% vert)] + [text (new text-field% + (label (string-constant indenting-prefs-extra-regexp)) + (callback (λ (tf evt) + (let ([str (send tf get-value)]) + (cond + [(equal? str "") + (bang-regexp #f)] + [else + (with-handlers ([exn:fail? + (λ (x) + (color-yellow (send tf get-editor)))]) + (bang-regexp (regexp str)) + (clear-color (send tf get-editor)))])))) + (parent vert))] + [add-button (make-object button% (string-constant add-keyword) + button-panel (add-button-callback string symbol box))] + [delete-button (make-object button% (string-constant remove-keyword) + button-panel (delete-callback box))]) + (send* button-panel + (set-alignment 'center 'center) + (stretchable-height #f)) + (send add-button min-width (send delete-button get-width)) + (values box text)))) + (define (color-yellow text) + (let ([sd (make-object style-delta%)]) + (send sd set-delta-background "yellow") + (send text change-style sd 0 (send text last-position)))) + (define (clear-color text) + (let ([sd (make-object style-delta%)]) + (send sd set-delta-background "white") + (send text change-style sd 0 (send text last-position)))) + (define (update-pref sel x) + (let ([pref (preferences:get 'framework:tabify)]) + (set-car! (sel pref) x) + (preferences:set 'framework:tabify pref))) + (define-values (begin-list-box begin-regexp-text) + (make-column "Begin" + 'begin + begin-keywords + (λ (x) (update-pref cdr x)))) + (define-values (define-list-box define-regexp-text) + (make-column "Define" + 'define + define-keywords + (λ (x) (update-pref cddr x)))) + (define-values (lambda-list-box lambda-regexp-text) + (make-column "Lambda" + 'lambda + lambda-keywords + (λ (x) (update-pref cdddr x)))) + (define update-list-boxes + (λ (hash-table) + (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] + [(reset) (λ (list-box keywords) + (send list-box clear) + (for-each (λ (x) (send list-box append x)) keywords))]) + (reset begin-list-box begin-keywords) + (reset define-list-box define-keywords) + (reset lambda-list-box lambda-keywords) + #t))) + (define update-gui + (λ (pref) + (update-list-boxes (car pref)) + (send begin-regexp-text set-value (or (object-name (cadr pref)) "")) + (send define-regexp-text set-value (or (object-name (caddr pref)) "")) + (send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) + (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) + main-panel) )