467 lines
17 KiB
Scheme
467 lines
17 KiB
Scheme
|
|
#|
|
|
|
|
There are three attributes for each preference:
|
|
|
|
- default set, or not
|
|
- marshalling function set, or not
|
|
- initialization still okay, or not
|
|
|
|
the state transitions / contracts are:
|
|
|
|
get(true, _, _) -> (true, _, false)
|
|
get(false, _, _) -> error default not yet set
|
|
|
|
set is just like get.
|
|
|
|
set-default(false, _, true) -> set-default(true, _, true)
|
|
set-default(true, _, _) -> error default already set
|
|
set-default(_, _, false) -> initialization not okay anymore /* cannot happen, I think */
|
|
|
|
set-un/marshall(true, false, true) -> (true, true, true)
|
|
.. otherwise error
|
|
|
|
for all syms:
|
|
prefs-snapshot(_, _, _) -> (_, _, false)
|
|
|
|
|#
|
|
|
|
(module preferences mzscheme
|
|
(require (lib "file.ss")
|
|
(lib "etc.ss")
|
|
(lib "contract.ss"))
|
|
|
|
(provide exn:struct:unknown-preference)
|
|
|
|
(define-struct (exn:unknown-preference exn) ())
|
|
|
|
;; these two names are for consistency
|
|
(define exn:make-unknown-preference make-exn:unknown-preference)
|
|
(define exn:struct:unknown-preference struct:exn:unknown-preference)
|
|
|
|
(define-syntax (provide/contract/docs stx)
|
|
(syntax-case stx ()
|
|
[(_ (name contract docs ...) ...)
|
|
(syntax (provide/contract (name contract) ...))]))
|
|
|
|
|
|
(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)))
|
|
|
|
;; preferences : hash-table[sym -o> any]
|
|
;; the current values of the preferences
|
|
(define preferences (make-hash-table))
|
|
|
|
;; marshalled : hash-table[sym -o> any]
|
|
;; the values of the preferences, as read in from the disk
|
|
;; each symbol will only be mapped in one of the preferences
|
|
;; hash-table and this hash-table, but not both.
|
|
(define marshalled (make-hash-table))
|
|
|
|
;; marshall-unmarshall : sym -o> un/marshall
|
|
(define marshall-unmarshall (make-hash-table))
|
|
|
|
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
|
(define callbacks (make-hash-table))
|
|
|
|
;; defaults : hash-table[sym -o> default]
|
|
(define defaults (make-hash-table))
|
|
|
|
;; these four functions determine the state of a preference
|
|
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
|
|
(define (pref-default-set? pref) (hash-table-bound? defaults pref))
|
|
(define (pref-can-init? pref)
|
|
(and (not snapshot-grabbed?)
|
|
(not (hash-table-bound? preferences pref))))
|
|
|
|
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
|
|
(define-struct un/marshall (marshall unmarshall))
|
|
|
|
;; type pref = (make-pref any)
|
|
(define-struct pref (value))
|
|
|
|
;; type default = (make-default any (any -> bool))
|
|
(define-struct default (value checker))
|
|
|
|
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
|
|
;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
|
|
(define-struct pref-callback (cb))
|
|
|
|
;; get : symbol -> any
|
|
;; return the current value of the preference `p'
|
|
;; exported
|
|
(define (preferences:get p)
|
|
(cond
|
|
[(pref-default-set? p)
|
|
|
|
;; unmarshall, if required
|
|
(when (hash-table-bound? marshalled p)
|
|
;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
|
|
(unless (hash-table-bound? preferences 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
|
|
"tried to get a preference but no default set for ~e"
|
|
p)]))
|
|
|
|
;; set : symbol any -> void
|
|
;; updates the preference
|
|
;; exported
|
|
(define (preferences:set p value) (multi-set (list p) (list value)))
|
|
|
|
;; set : symbol any -> void
|
|
;; updates the preference
|
|
;; exported
|
|
|
|
(define (multi-set ps values)
|
|
(for-each
|
|
(λ (p value)
|
|
(cond
|
|
[(pref-default-set? p)
|
|
(let ([default (hash-table-get defaults p)])
|
|
(unless ((default-checker default) value)
|
|
(error 'preferences:set
|
|
"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
|
|
'preferences:set "tried to set the preference ~e to ~e, but no default is set"
|
|
p
|
|
value)]))
|
|
ps values)
|
|
|
|
((preferences:low-level-put-preferences)
|
|
(map add-pref-prefix ps)
|
|
(map (λ (p value) (marshall-pref p value))
|
|
ps
|
|
values))
|
|
|
|
(void))
|
|
|
|
(define preferences:low-level-put-preferences (make-parameter put-preferences))
|
|
|
|
(define (raise-unknown-preference-error sym fmt . args)
|
|
(raise (exn:make-unknown-preference
|
|
(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/ec k
|
|
(let* ([unmarshall-fn (un/marshall-unmarshall
|
|
(hash-table-get marshall-unmarshall
|
|
p
|
|
(λ () (k data))))]
|
|
[default (hash-table-get defaults p)]
|
|
[result (unmarshall-fn data)])
|
|
(if ((default-checker default) result)
|
|
result
|
|
(default-value default)))))
|
|
|
|
;; add-callback : sym (-> void) -> void
|
|
(define preferences:add-callback
|
|
(opt-lambda (p callback [weak? #f])
|
|
(let ([new-cb (make-pref-callback (if weak?
|
|
(make-weak-box callback)
|
|
callback))])
|
|
(hash-table-put! callbacks
|
|
p
|
|
(append
|
|
(hash-table-get callbacks p (λ () null))
|
|
(list new-cb)))
|
|
(λ ()
|
|
(hash-table-put!
|
|
callbacks
|
|
p
|
|
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
|
|
(cond
|
|
[(null? callbacks) null]
|
|
[else
|
|
(let ([callback (car callbacks)])
|
|
(cond
|
|
[(eq? callback new-cb)
|
|
(loop (cdr callbacks))]
|
|
[else
|
|
(cons (car callbacks) (loop (cdr callbacks)))]))])))))))
|
|
|
|
;; check-callbacks : sym val -> void
|
|
(define (check-callbacks p value)
|
|
(let ([new-callbacks
|
|
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
|
|
(cond
|
|
[(null? callbacks) null]
|
|
[else
|
|
(let* ([callback (car callbacks)]
|
|
[cb (pref-callback-cb callback)])
|
|
(cond
|
|
[(weak-box? cb)
|
|
(let ([v (weak-box-value cb)])
|
|
(if v
|
|
(begin
|
|
(v p value)
|
|
(cons callback (loop (cdr callbacks))))
|
|
(loop (cdr callbacks))))]
|
|
[else
|
|
(cb p value)
|
|
(cons callback (loop (cdr callbacks)))]))]))])
|
|
(if (null? new-callbacks)
|
|
(hash-table-remove! callbacks p)
|
|
(hash-table-put! callbacks p new-callbacks))))
|
|
|
|
(define (preferences:set-un/marshall p marshall unmarshall)
|
|
(cond
|
|
[(and (pref-default-set? p)
|
|
(not (pref-un/marshall-set? p))
|
|
(pref-can-init? p))
|
|
(hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
|
|
[(not (pref-default-set? p))
|
|
(error 'preferences:set-un/marshall
|
|
"must call set-default for ~s before calling set-un/marshall for ~s"
|
|
p p)]
|
|
[(pref-un/marshall-set? p)
|
|
(error 'preferences:set-un/marshall
|
|
"already set un/marshall for ~e"
|
|
p)]
|
|
[(not (pref-can-init? p))
|
|
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
|
|
|
|
(define (hash-table-bound? ht s)
|
|
(let/ec k
|
|
(hash-table-get ht s (λ () (k #f)))
|
|
#t))
|
|
|
|
(define (preferences:restore-defaults)
|
|
(hash-table-for-each
|
|
defaults
|
|
(λ (p def) (preferences:set p (default-value def)))))
|
|
|
|
;; set-default : (sym TST (TST -> boolean) -> void
|
|
(define (preferences:set-default p default-value checker)
|
|
(cond
|
|
[(and (not (pref-default-set? p))
|
|
(pref-can-init? p))
|
|
(let ([default-okay? (checker default-value)])
|
|
(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))
|
|
(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"
|
|
p)]
|
|
[(pref-default-set? p)
|
|
(error 'preferences:set-default
|
|
"preferences default already set for ~e" p)]
|
|
[(not (pref-can-init? p))
|
|
(error 'preferences:set-default
|
|
"can no longer set the default for ~e" p)]))
|
|
|
|
;; marshall-pref : symbol any -> (list symbol printable)
|
|
(define (marshall-pref p value)
|
|
(let/ec k
|
|
(let* ([marshaller
|
|
(un/marshall-marshall
|
|
(hash-table-get marshall-unmarshall p (λ () (k value))))])
|
|
(marshaller value))))
|
|
|
|
(define-struct preferences:snapshot (x))
|
|
(define snapshot-grabbed? #f)
|
|
(define (preferences:get-prefs-snapshot)
|
|
(set! snapshot-grabbed? #t)
|
|
(make-preferences:snapshot (hash-table-map defaults (λ (k v) (cons k (preferences:get k))))))
|
|
|
|
(define (preferences:restore-prefs-snapshot snapshot)
|
|
(multi-set (map car (preferences:snapshot-x snapshot))
|
|
(map cdr (preferences:snapshot-x snapshot)))
|
|
(void))
|
|
|
|
|
|
(provide/contract/docs
|
|
(preferences:snapshot?
|
|
(-> any/c boolean?)
|
|
(arg)
|
|
"Determines if its argument is a preferences snapshot."
|
|
""
|
|
"See also "
|
|
"@flink preferences:get-prefs-snapshot"
|
|
" and "
|
|
"@flink preferences:restore-prefs-snapshot %"
|
|
".")
|
|
(preferences:restore-prefs-snapshot
|
|
(-> preferences:snapshot? void?)
|
|
(snapshot)
|
|
"Restores the preferences saved in \\var{snapshot}."
|
|
""
|
|
"See also "
|
|
"@flink preferences:get-prefs-snapshot %"
|
|
".")
|
|
|
|
(preferences:get-prefs-snapshot
|
|
(-> preferences:snapshot?)
|
|
()
|
|
"Caches all of the current values of the preferences and returns them."
|
|
""
|
|
"See also "
|
|
"@flink preferences:restore-prefs-snapshot %"
|
|
".")
|
|
|
|
(exn:make-unknown-preference
|
|
(string? continuation-mark-set? . -> . exn:unknown-preference?)
|
|
(message continuation-marks)
|
|
"Creates an unknown preference exception.")
|
|
(exn:unknown-preference?
|
|
(any/c . -> . boolean?)
|
|
(exn)
|
|
"Determines if a value is an unknown preference exn.")
|
|
|
|
(preferences:low-level-put-preferences
|
|
any/c
|
|
()
|
|
"This is a parameter (see "
|
|
"\\Mzhyperref{parameters}{mz:parameters} for information about parameters)"
|
|
"which is called when a preference is saved. Its interface should "
|
|
"be just like mzlib's \\scheme|put-preference|.")
|
|
|
|
(preferences:get
|
|
(symbol? . -> . any/c)
|
|
(symbol)
|
|
"See also"
|
|
"@flink preferences:set-default %"
|
|
"."
|
|
""
|
|
"\\rawscm{preferences:get} returns the value for the preference"
|
|
"\\var{symbol}. It raises"
|
|
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
|
|
"if the preference's default has not been set.")
|
|
(preferences:set
|
|
(symbol? any/c . -> . void?)
|
|
(symbol value)
|
|
"See also"
|
|
"@flink preferences:set-default %"
|
|
"."
|
|
""
|
|
"\\rawscm{preferences:set-preference} sets the preference"
|
|
"\\var{symbol} to \\var{value}. This should be called when the"
|
|
"users requests a change to a preference."
|
|
""
|
|
"This function immediately writes the preference value to disk."
|
|
""
|
|
"It raises"
|
|
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
|
|
"if the preference's default has not been set.")
|
|
(preferences:add-callback
|
|
(opt-> (symbol? (symbol? any/c . -> . any/c))
|
|
(boolean?)
|
|
(-> void?))
|
|
((p f)
|
|
((weak? #f)))
|
|
"This function adds a callback which is called with a symbol naming a"
|
|
"preference and it's value, when the preference changes."
|
|
"\\rawscm{preferences:add-callback} returns a thunk, which when"
|
|
"invoked, removes the callback from this preference."
|
|
""
|
|
"If \\var{weak?} is true, the preferences system will only hold on to"
|
|
"the callback weakly."
|
|
""
|
|
"The callbacks will be called in the order in which they were added."
|
|
""
|
|
"If you are adding a callback for a preference that requires"
|
|
"marshalling and unmarshalling, you must set the marshalling and"
|
|
"unmarshalling functions by calling"
|
|
"\\iscmprocedure{preferences:set-un/marshall} before adding a callback."
|
|
""
|
|
"This function raises"
|
|
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}"
|
|
"if the preference has not been set.")
|
|
(preferences:set-default
|
|
(symbol? any/c (any/c . -> . any) . -> . void?)
|
|
(symbol value test)
|
|
"This function must be called every time your application starts up, before any call to"
|
|
"@flink preferences:get %"
|
|
", "
|
|
"@flink preferences:set"
|
|
"(for any given preference)."
|
|
""
|
|
"If you use"
|
|
"@flink preferences:set-un/marshall %"
|
|
", you must call this function before calling it."
|
|
""
|
|
"This sets the default value of the preference \\var{symbol} to"
|
|
"\\var{value}. If the user has chosen a different setting,"
|
|
"the user's setting"
|
|
"will take precedence over the default value."
|
|
""
|
|
"The last argument, \\var{test} is used as a safeguard. That function is"
|
|
"called to determine if a preference read in from a file is a valid"
|
|
"preference. If \\var{test} returns \\rawscm{\\#t}, then the preference is"
|
|
"treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is"
|
|
"used.")
|
|
(preferences:set-un/marshall
|
|
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
|
|
(symbol marshall unmarshall)
|
|
"\\rawscm{preference:set-un/marshall} is used to specify marshalling and"
|
|
"unmarshalling functions for the preference"
|
|
"\\var{symbol}. \\var{marshall} will be called when the users saves their"
|
|
"preferences to turn the preference value for \\var{symbol} into a"
|
|
"printable value. \\var{unmarshall} will be called when the user's"
|
|
"preferences are read from the file to transform the printable value"
|
|
"into it's internal representation. If \\rawscm{preference:set-un/marshall}"
|
|
"is never called for a particular preference, the values of that"
|
|
"preference are assumed to be printable."
|
|
""
|
|
"If the unmarshalling function returns a value that does not meet the"
|
|
"guard passed to "
|
|
"@flink preferences:set-default"
|
|
"for this preference, the default value is used."
|
|
""
|
|
"The \\var{marshall} function might be called with any value returned"
|
|
"from \\scheme{read} and it must not raise an error (although it"
|
|
"can return arbitrary results if it gets bad input). This might"
|
|
"happen when the preferences file becomes corrupted, or is edited"
|
|
"by hand."
|
|
""
|
|
"\\rawscm{preference:set-un/marshall} must be called before calling"
|
|
"@flink preferences:get %"
|
|
", "
|
|
"@flink preferences:set %"
|
|
".")
|
|
|
|
(preferences:restore-defaults
|
|
(-> void?)
|
|
()
|
|
"\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
|
|
"default preferences.")))
|