added docs for the gui-utils and the textual preferences to the framework
svn: r9503 original commit: d07eff8bceb5d1b07deb074d1e180f3f9ba713d7
This commit is contained in:
Robby Findler
parent
35f5253f8d
commit
45a7f4f451
File diff suppressed because it is too large
Load Diff
|
|
@ -1,4 +1,5 @@
|
|||
|
||||
#reader scribble/reader
|
||||
#lang scheme/gui
|
||||
#|
|
||||
|
||||
There are three attributes for each preference:
|
||||
|
|
@ -26,443 +27,438 @@ the state transitions / contracts are:
|
|||
|
||||
|#
|
||||
|
||||
(module preferences mzscheme
|
||||
(require mzlib/file
|
||||
mzlib/etc
|
||||
mzlib/contract)
|
||||
|
||||
(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) ...))]))
|
||||
(require scribble/srcdoc)
|
||||
(require/doc scheme/base scribble/manual)
|
||||
|
||||
|
||||
(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:
|
||||
(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 old-preferences-symbol 'plt:framework-prefs)
|
||||
(define old-preferences (make-hasheq))
|
||||
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
|
||||
(for-each
|
||||
(λ (line) (hash-set! 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-hasheq))
|
||||
|
||||
;; 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-hasheq))
|
||||
|
||||
;; marshall-unmarshall : sym -o> un/marshall
|
||||
(define marshall-unmarshall (make-hasheq))
|
||||
|
||||
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
||||
(define callbacks (make-hasheq))
|
||||
|
||||
;; defaults : hash-table[sym -o> default]
|
||||
(define defaults (make-hasheq))
|
||||
|
||||
;; 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)
|
||||
(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)
|
||||
(hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p))))
|
||||
(hash-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-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
|
||||
(hash-set! preferences p (unmarshall-pref p (hash-ref 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-remove! old-preferences p))
|
||||
|
||||
;; if it still isn't set, take the default value
|
||||
(unless (hash-table-bound? preferences p)
|
||||
(hash-set! preferences p (default-value (hash-ref defaults p))))
|
||||
|
||||
(hash-ref 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)]))
|
||||
|
||||
(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))))
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
(define (preferences:set p value) (multi-set (list p) (list value)))
|
||||
|
||||
;; unmarshall-pref : symbol marshalled -> any
|
||||
;; unmarshalls a preference read from the disk
|
||||
(define (unmarshall-pref p data)
|
||||
(let* ([un/marshall (hash-table-get marshall-unmarshall p #f)]
|
||||
[result (if un/marshall
|
||||
((un/marshall-unmarshall un/marshall) data)
|
||||
data)]
|
||||
[default (hash-table-get defaults p)])
|
||||
(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.")
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
|
||||
(preferences:low-level-put-preferences
|
||||
(parameter/c (-> (listof symbol?) (listof any/c) any))
|
||||
()
|
||||
"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?
|
||||
|
||||
;; important that this arg only has a flat contract
|
||||
;; so that no wrapper is created, so that
|
||||
;; the weak box stuff works ...
|
||||
(λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
|
||||
(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.")))
|
||||
(define (multi-set ps values)
|
||||
(for-each
|
||||
(λ (p value)
|
||||
(cond
|
||||
[(pref-default-set? p)
|
||||
(let ([default (hash-ref 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-set! 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* ([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])
|
||||
(let ([new-cb (make-pref-callback (if weak?
|
||||
(make-weak-box callback)
|
||||
callback))])
|
||||
(hash-set! callbacks
|
||||
p
|
||||
(append
|
||||
(hash-ref callbacks p (λ () null))
|
||||
(list new-cb)))
|
||||
(λ ()
|
||||
(hash-set!
|
||||
callbacks
|
||||
p
|
||||
(let loop ([callbacks (hash-ref 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-ref 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-remove! callbacks p)
|
||||
(hash-set! 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-set! 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-ref ht s (λ () (k #f)))
|
||||
#t))
|
||||
|
||||
(define (preferences:restore-defaults)
|
||||
(hash-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-set! 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-set! 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-ref 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-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/doc
|
||||
(proc-doc/names
|
||||
preferences:snapshot?
|
||||
(-> any/c boolean?)
|
||||
(arg)
|
||||
@{Determines if its argument is a preferences snapshot.
|
||||
|
||||
See also
|
||||
@scheme[preferences:get-prefs-snapshot] and
|
||||
@scheme[preferences:restore-prefs-snapshot].})
|
||||
(proc-doc/names
|
||||
preferences:restore-prefs-snapshot
|
||||
(-> preferences:snapshot? void?)
|
||||
(snapshot)
|
||||
@{Restores the preferences saved in @scheme[snapshot].
|
||||
|
||||
See also @scheme[preferences:get-prefs-snapshot].})
|
||||
|
||||
(proc-doc/names
|
||||
preferences:get-prefs-snapshot
|
||||
(-> preferences:snapshot?)
|
||||
()
|
||||
@{Caches all of the current values of the preferences and returns them.
|
||||
|
||||
See also
|
||||
@scheme[preferences:restore-prefs-snapshot].})
|
||||
|
||||
|
||||
(proc-doc/names
|
||||
exn:make-unknown-preference
|
||||
(string? continuation-mark-set? . -> . exn:unknown-preference?)
|
||||
(message continuation-marks)
|
||||
@{Creates an unknown preference exception.})
|
||||
(proc-doc/names
|
||||
exn:unknown-preference?
|
||||
(any/c . -> . boolean?)
|
||||
(exn)
|
||||
@{Determines if a value is an unknown preference exn.})
|
||||
|
||||
(parameter-doc
|
||||
preferences:low-level-put-preferences
|
||||
(parameter/c (-> (listof symbol?) (listof any/c) any))
|
||||
put-preference
|
||||
@{This parameter's value
|
||||
is called when to save preference the preferences. Its interface should
|
||||
be just like mzlib's @scheme[put-preference].})
|
||||
|
||||
(proc-doc/names
|
||||
preferences:get
|
||||
(symbol? . -> . any/c)
|
||||
(symbol)
|
||||
@{See also @scheme[preferences:set-default].
|
||||
|
||||
@scheme[preferences:get] returns the value for the preference
|
||||
@scheme[symbol]. It raises
|
||||
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
|
||||
@scheme[exn:unknown-preference]
|
||||
if the preference's default has not been set.})
|
||||
(proc-doc/names
|
||||
preferences:set
|
||||
(symbol? any/c . -> . void?)
|
||||
(symbol value)
|
||||
@{See also @scheme[preferences:set-default].
|
||||
|
||||
@scheme[preferences:set-preference] sets the preference
|
||||
@scheme[symbol] to @scheme[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
|
||||
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
|
||||
if the preference's default has not been set.})
|
||||
(proc-doc/names
|
||||
preferences:add-callback
|
||||
(->* (symbol?
|
||||
|
||||
;; important that this arg only has a flat contract
|
||||
;; so that no wrapper is created, so that
|
||||
;; the weak box stuff works ...
|
||||
(λ (x) (and (procedure? x) (procedure-arity-includes? x 2))))
|
||||
(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.
|
||||
@scheme[preferences:add-callback] returns a thunk, which when
|
||||
invoked, removes the callback from this preference.
|
||||
|
||||
If @scheme[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
|
||||
@scheme[preferences:set-un/marshall] before adding a callback.
|
||||
|
||||
This function raises
|
||||
@index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
|
||||
@scheme[exn:unknown-preference]
|
||||
if the preference has not been set.})
|
||||
(proc-doc/names
|
||||
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
|
||||
@scheme[preferences:get] or
|
||||
@scheme[preferences:set]
|
||||
(for any given preference).
|
||||
|
||||
If you use
|
||||
@scheme[preferences:set-un/marshall],
|
||||
you must call this function before calling it.
|
||||
|
||||
This sets the default value of the preference @scheme[symbol] to
|
||||
@scheme[value]. If the user has chosen a different setting,
|
||||
the user's setting
|
||||
will take precedence over the default value.
|
||||
|
||||
The last argument, @scheme[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 @scheme[test] returns @scheme[#t], then the preference is
|
||||
treated as valid. If @scheme[test] returns @scheme[#f] then the default is
|
||||
used.})
|
||||
(proc-doc/names
|
||||
preferences:set-un/marshall
|
||||
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
|
||||
(symbol marshall unmarshall)
|
||||
@{@scheme[preference:set-un/marshall] is used to specify marshalling and
|
||||
unmarshalling functions for the preference
|
||||
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
|
||||
preferences to turn the preference value for @scheme[symbol] into a
|
||||
printable value. @scheme[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 @scheme[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
|
||||
@scheme[preferences:set-default]
|
||||
for this preference, the default value is used.
|
||||
|
||||
The @scheme[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.
|
||||
|
||||
@scheme[preference:set-un/marshall] must be called before calling
|
||||
@scheme[preferences:get],
|
||||
@scheme[preferences:set].})
|
||||
|
||||
(proc-doc/names
|
||||
preferences:restore-defaults
|
||||
(-> void?)
|
||||
()
|
||||
@{@scheme[(preferences:restore-defaults)]
|
||||
restores the users's configuration to the
|
||||
default preferences.}))
|
||||
|
|
|
|||
|
|
@ -4,11 +4,6 @@
|
|||
(require scribble/srcdoc)
|
||||
(require/doc scheme/base scribble/manual)
|
||||
|
||||
(define-syntax (provide/contract/docs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(define (test:top-level-focus-window-has? pred)
|
||||
(let ([tlw (get-top-level-focus-window)])
|
||||
(and tlw
|
||||
|
|
|
|||
|
|
@ -5,9 +5,13 @@
|
|||
|
||||
@title{@bold{Framework}: PLT GUI Application Framework}
|
||||
|
||||
The framework provides these libraries:
|
||||
@itemize{
|
||||
@item{Mode}
|
||||
@item{``Cannot parse docs for handler:open-file''}
|
||||
@item{Check indexing in preferences:get}
|
||||
}
|
||||
|
||||
@itemize{
|
||||
@item{@bold{Entire Framework}
|
||||
|
||||
@itemize{
|
||||
|
|
@ -74,8 +78,7 @@ The precise set of exported names is:
|
|||
@scheme[preferences:restore-defaults].
|
||||
}}
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
@section{Thanks}
|
||||
@bold{Thanks}
|
||||
|
||||
Thanks to Shriram Krishnamurthi, Cormac Flanagan, Matthias
|
||||
Felleisen, Ian Barland, Gann Bierner, Richard Cobbe, Dan
|
||||
|
|
@ -84,33 +87,33 @@ Johnathan Franklin, Mark Krentel, Corky Cartwright, Michael
|
|||
Ernst, Kennis Koldewyn, Bruce Duba, and many others for
|
||||
their feedback and help.
|
||||
|
||||
|
||||
@include-section["framework-application.scrbl"]
|
||||
@include-section["framework-autosave.scrbl"]
|
||||
@include-section["framework-canvas.scrbl"]
|
||||
@include-section["framework-color-model.scrbl"]
|
||||
@include-section["framework-color-prefs.scrbl"]
|
||||
@include-section["framework-color.scrbl"]
|
||||
@include-section["framework-comment-box.scrbl"]
|
||||
@include-section["framework-editor.scrbl"]
|
||||
@include-section["framework-exit.scrbl"]
|
||||
@include-section["framework-finder.scrbl"]
|
||||
@include-section["framework-frame.scrbl"]
|
||||
@include-section["framework-group.scrbl"]
|
||||
@include-section["framework-handler.scrbl"]
|
||||
@include-section["framework-icon.scrbl"]
|
||||
@include-section["framework-keymap.scrbl"]
|
||||
@;include-section["framework-main.scrbl"]
|
||||
@include-section["framework-menu.scrbl"]
|
||||
@;include-section["framework-mode.scrbl"]
|
||||
@include-section["framework-number-snip.scrbl"]
|
||||
@include-section["framework-panel.scrbl"]
|
||||
@include-section["framework-pasteboard.scrbl"]
|
||||
@include-section["framework-path-utils.scrbl"]
|
||||
@include-section["framework-preferences.scrbl"]
|
||||
@include-section["framework-scheme.scrbl"]
|
||||
@include-section["framework-text.scrbl"]
|
||||
@include-section["framework-test.scrbl"]
|
||||
@include-section["framework-version.scrbl"]
|
||||
@include-section["application.scrbl"]
|
||||
@include-section["autosave.scrbl"]
|
||||
@include-section["canvas.scrbl"]
|
||||
@include-section["color-model.scrbl"]
|
||||
@include-section["color-prefs.scrbl"]
|
||||
@include-section["color.scrbl"]
|
||||
@include-section["comment-box.scrbl"]
|
||||
@include-section["editor.scrbl"]
|
||||
@include-section["exit.scrbl"]
|
||||
@include-section["finder.scrbl"]
|
||||
@include-section["frame.scrbl"]
|
||||
@include-section["group.scrbl"]
|
||||
@include-section["gui-utils.scrbl"]
|
||||
@include-section["handler.scrbl"]
|
||||
@include-section["icon.scrbl"]
|
||||
@include-section["keymap.scrbl"]
|
||||
@include-section["menu.scrbl"]
|
||||
@include-section["mode.scrbl"]
|
||||
@include-section["number-snip.scrbl"]
|
||||
@include-section["panel.scrbl"]
|
||||
@include-section["pasteboard.scrbl"]
|
||||
@include-section["path-utils.scrbl"]
|
||||
@include-section["preferences.scrbl"]
|
||||
@include-section["preferences-text.scrbl"]
|
||||
@include-section["scheme.scrbl"]
|
||||
@include-section["text.scrbl"]
|
||||
@include-section["test.scrbl"]
|
||||
@include-section["version.scrbl"]
|
||||
|
||||
@index-section[]
|
||||
|
|
|
|||
10
collects/scribblings/framework/gui-utils.scrbl
Normal file
10
collects/scribblings/framework/gui-utils.scrbl
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual scribble/extract)
|
||||
@(require (for-label framework/framework))
|
||||
@(require (for-label scheme/gui))
|
||||
@title{GUI Utilities}
|
||||
|
||||
@(require framework/framework-docs)
|
||||
@(defmodule framework/gui-utils)
|
||||
|
||||
@(include-extracted (lib "gui-utils.ss" "framework"))
|
||||
10
collects/scribblings/framework/preferences-text.scrbl
Normal file
10
collects/scribblings/framework/preferences-text.scrbl
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual scribble/extract)
|
||||
@(require (for-label framework/framework))
|
||||
@(require (for-label scheme/gui))
|
||||
@title{Preferences, Textual}
|
||||
|
||||
@(require framework/framework-docs)
|
||||
@(defmodule framework/preferences)
|
||||
|
||||
@(include-extracted (lib "preferences.ss" "framework"))
|
||||
Loading…
Reference in New Issue
Block a user