fixed bug in tabify preferences, changed preferences strategy to only read once (but write on each 'set') and made old-style preferences still be read, if they are there
svn: r5070 original commit: 1bf0d52c34c917f3d785b3e9fa44000518c72513
This commit is contained in:
Robby Findler
parent
1f0030f873
commit
9dfd53b32b
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user