diff --git a/collects/framework/preferences.ss b/collects/framework/preferences.ss new file mode 100644 index 0000000000..137bc662c4 --- /dev/null +++ b/collects/framework/preferences.ss @@ -0,0 +1,466 @@ + +#| + +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."))) \ No newline at end of file