suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

separated preferences library out to be used by mz

Browse Source 
svn: r5537

original commit: 13110a2113d1a8e2174e7e381809cb90916d18bf
This commit is contained in:
Robby Findler 2007-02-01 23:55:20 +00:00
parent 18eb1751c2
commit 4a5976a827
19 changed files with 75 additions and 517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
collects/framework/framework.ss
View File

@ -6,6 +6,7 @@
(lib "mred.ss" "mred")
(lib "class.ss")
"preferences.ss"
"test.ss"
"gui-utils.ss"
"decorated-editor-snip.ss"
@ -19,7 +20,6 @@
(prefix application: framework:application-class^)
(prefix version: framework:version-class^)
(prefix color-model: framework:color-model-class^)
(prefix exn: framework:exn-class^)
(prefix mode: framework:mode-class^)
(prefix exit: framework:exit-class^)
(prefix menu: framework:menu-class^)
@ -46,11 +46,9 @@
(provide (all-from "test.ss")
(all-from "gui-utils.ss")
(all-from "preferences.ss")
(all-from "decorated-editor-snip.ss"))
(provide exn:struct:unknown-preference
exn:struct:exn)
(define-syntax (provide/contract/docs stx)
(syntax-case stx ()
[(_ (name contract docs ...) ...)
@ -107,23 +105,6 @@
"@flink version:add-spec %"
".")
(exn:make-exn
(string? continuation-mark-set? . -> . exn?)
(message continuation-marks)
"Creates a framework exception.")
(exn:exn?
(any/c . -> . boolean?)
(exn)
"Tests if a value is a framework exception.")
(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.")
(application:current-app-name
(case-> (-> string?)
(string? . -> . void?))
@ -137,116 +118,6 @@
"the second case in the case-lambda sets"
"the name of the application to \\var{name}.")
(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.")
(preferences:add-panel
((or/c string? (cons/c string? (listof string?)))
((is-a?/c area-container-window<%>)
@ -279,7 +150,7 @@
"\\var{f} is expected to add a new child panel to it and add"
"whatever preferences configuration controls it wants to that"
"panel. Then, \\var{f}'s should return the panel it added.")
(preferences:add-editor-checkbox-panel
(-> void?)
()

8
collects/framework/private/autosave.ss
View File

@ -4,15 +4,13 @@
(lib "file.ss")
"sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred") ;; remove this!
"../preferences.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "string-constant.ss" "string-constants")
(lib "unit.ss"))
(lib "string-constant.ss" "string-constants"))
(import mred^
[prefix exit: framework:exit^]
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^]
[prefix scheme: framework:scheme^]
[prefix editor: framework:editor^]

4
collects/framework/private/canvas.ss
View File

@ -1,10 +1,10 @@
(module canvas (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
"../preferences.ss"
(lib "mred-sig.ss" "mred"))
(import mred^
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^]
[prefix text: framework:text^])

2
collects/framework/private/color-prefs.ss
View File

@ -1,9 +1,9 @@
(module color-prefs (lib "a-unit.ss")
(require (lib "class.ss")
(lib "unit.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "string-constant.ss" "string-constants")
"../preferences.ss"
"sig.ss")
(import [prefix preferences: framework:preferences^]

9
collects/framework/private/color.ss
View File

@ -1,16 +1,15 @@
(module color (lib "a-unit.ss")
(require (lib "class.ss")
(lib "etc.ss")
(lib "thread.ss")
(lib "thread.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "token-tree.ss" "syntax-color")
(lib "paren-tree.ss" "syntax-color")
(lib "default-lexer.ss" "syntax-color")
(lib "unit.ss")
"../preferences.ss"
"sig.ss")
(import [prefix preferences: framework:preferences^]
[prefix icon: framework:icon^]
(import [prefix icon: framework:icon^]
[prefix mode: framework:mode^]
[prefix text: framework:text^]
[prefix color-prefs: framework:color-prefs^]

4
collects/framework/private/editor.ss
View File

@ -3,7 +3,8 @@
(require (lib "class.ss")
(lib "string-constant.ss" "string-constants")
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
"../gui-utils.ss"
(lib "etc.ss")
(lib "mred-sig.ss" "mred")
(lib "file.ss"))
@ -14,7 +15,6 @@
[prefix path-utils: framework:path-utils^]
[prefix keymap: framework:keymap^]
[prefix icon: framework:icon^]
[prefix preferences: framework:preferences^]
[prefix text: framework:text^]
[prefix pasteboard: framework:pasteboard^]
[prefix frame: framework:frame^]

11
collects/framework/private/exit.ss
View File

@ -1,14 +1,11 @@
(module exit (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
"sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss")
(lib "etc.ss"))
"../preferences.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred"))
(import mred^
[prefix preferences: framework:preferences^])
(import mred^)
(export (rename framework:exit^
(-exit exit)))

5
collects/framework/private/finder.ss
View File

@ -2,17 +2,14 @@
(module finder (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
"sig.ss"
"../gui-utils.ss"
(lib "class.ss")
"../preferences.ss"
(lib "mred-sig.ss" "mred")
(lib "string.ss")
(lib "list.ss")
(lib "file.ss")
(lib "etc.ss"))
(import mred^
[prefix preferences: framework:preferences^]
[prefix keymap: framework:keymap^])
(export (rename framework:finder^

3
collects/framework/private/frame.ss
View File

@ -4,7 +4,8 @@
(lib "class.ss")
(lib "include.ss")
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
"../gui-utils.ss"
"bday.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")

4
collects/framework/private/group.ss
View File

@ -3,7 +3,8 @@
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "file.ss"))
@ -11,7 +12,6 @@
(import mred^
[prefix application: framework:application^]
[prefix frame: framework:frame^]
[prefix preferences: framework:preferences^]
[prefix text: framework:text^]
[prefix canvas: framework:canvas^]
[prefix menu: framework:menu^])

4
collects/framework/private/handler.ss
View File

@ -4,7 +4,8 @@
(lib "list.ss")
(lib "hierlist.ss" "hierlist")
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss")
(lib "string-constant.ss" "string-constants"))
@ -14,7 +15,6 @@
[prefix finder: framework:finder^]
[prefix group: framework:group^]
[prefix text: framework:text^]
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^])
(export framework:handler^)
(init-depend framework:frame^)

2
collects/framework/private/keymap.ss
View File

@ -5,11 +5,11 @@
(lib "list.ss")
(lib "mred-sig.ss" "mred")
(lib "match.ss")
"../preferences.ss"
"sig.ss")
(import mred^
[prefix preferences: framework:preferences^]
[prefix finder: framework:finder^]
[prefix handler: framework:handler^]
[prefix frame: framework:frame^]

11
collects/framework/private/main.ss
View File

@ -1,9 +1,8 @@
(module main (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
"../gui-utils.ss"
(lib "string-constant.ss" "string-constants")
(lib "mred-sig.ss" "mred"))
"../preferences.ss"
(lib "mred-sig.ss" "mred"))
(import mred^
[prefix preferences: framework:preferences^]
@ -17,8 +16,10 @@
(init-depend framework:preferences^ framework:exit^ framework:editor^
framework:color-prefs^ framework:scheme^)
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:low-level-put-preferences preferences:put-preferences/gui)
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:square-bracket:cond/offset
'(("case-lambda" 0)
("cond" 0)

6
collects/framework/private/menu.ss
View File

@ -1,10 +1,10 @@
(module menu (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
"../preferences.ss"
(lib "mred-sig.ss" "mred"))
(import mred^
[prefix preferences: framework:preferences^])
(import mred^)
(export framework:menu^)
(define can-restore<%>

4
collects/framework/private/number-snip.ss
View File

@ -3,10 +3,10 @@
(require "sig.ss"
(lib "mred-sig.ss" "mred")
(lib "class.ss")
"../preferences.ss"
(lib "string-constant.ss" "string-constants"))
(import mred^
[prefix preferences: framework:preferences^])
(import mred^)
(export (rename framework:number-snip^
[-snip-class% snip-class%]))
(init-depend mred^)

354
collects/framework/private/preferences.ss
View File

@ -30,139 +30,18 @@ the state transitions / contracts are:
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
(lib "file.ss")
(lib "etc.ss")
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
(lib "mred-sig.ss" "mred")
(lib "pretty.ss")
(lib "list.ss"))
(import mred^
[prefix exn: framework:exn^]
[prefix exit: framework:exit^]
[prefix panel: framework:panel^]
[prefix frame: framework:frame^])
(export framework:preferences^)
(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 (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 (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)
(put-preferences/gui (map add-pref-prefix ps)
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(define (put-preferences/gui ps vs)
(define (fail-func path)
(let ([mb-ans
@ -196,180 +75,9 @@ the state transitions / contracts are:
ps
vs
fail-func)))
(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 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 (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 (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)
(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 (read-err input msg)
(message-box
(string-constant preferences)
(let* ([max-len 150]
[s1 (format "~s" input)]
[ell "..."]
[s2 (if (<= (string-length s1) max-len)
s1
(string-append
(substring s1 0 (- max-len
(string-length ell)))
ell))])
(string-append
(string-constant error-reading-preferences)
"\n"
msg
"\n"
s2))))
(define snapshot-grabbed? #f)
(define (get-prefs-snapshot)
(set! snapshot-grabbed? #t)
(hash-table-map defaults (λ (k v) (cons k (get k)))))
(define (restore-prefs-snapshot snapshot)
(multi-set (map car snapshot)
(map cdr snapshot)))
;; ; ;;;
; ;
; ;
;;;; ;;; ;;;; ; ;;; ;;; ;
; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;
;;; ; ;;;;; ;;; ; ;;;;;; ;;; ;;;;
;
;
;;;
;; ppanel-tree =
;; (union (make-ppanel-leaf string (union #f panel) (panel -> panel))
;; (make-ppanel-interior string (union #f panel) (listof panel-tree)))
@ -465,12 +173,12 @@ the state transitions / contracts are:
(define can-close-dialog-callbacks null)
(define (make-preferences-dialog)
(letrec ([stashed-prefs (get-prefs-snapshot)]
(letrec ([stashed-prefs (preferences:get-prefs-snapshot)]
[frame-stashed-prefs%
(class frame:basic%
(define/override (show on?)
(when on?
(set! stashed-prefs (get-prefs-snapshot)))
(set! stashed-prefs (preferences:get-prefs-snapshot)))
(super show on?))
(super-new))]
[frame
@ -529,7 +237,7 @@ the state transitions / contracts are:
(hide-dialog)))]
[cancel-callback (λ (_1 _2)
(hide-dialog)
(restore-prefs-snapshot stashed-prefs))])
(preferences:restore-prefs-snapshot stashed-prefs))])
(gui-utils:ok/cancel-buttons
bottom-panel
ok-callback
@ -574,14 +282,15 @@ the state transitions / contracts are:
(define (make-check main pref title bool->pref pref->bool)
(let* ([callback
(λ (check-box _)
(set pref (bool->pref (send check-box get-value))))]
[pref-value (get pref)]
(preferences:set pref (bool->pref (send check-box get-value))))]
[pref-value (preferences:get pref)]
[initial-value (pref->bool pref-value)]
[c (make-object check-box% title main callback)])
(send c set-value initial-value)
(add-callback pref
(λ (p v)
(send c set-value (pref->bool v))))))
(preferences:add-callback
pref
(λ (p v)
(send c set-value (pref->bool v))))))
(define (make-recent-items-slider parent)
(let ([slider (instantiate slider% ()
@ -589,11 +298,11 @@ the state transitions / contracts are:
(label (string-constant number-of-open-recent-items))
(min-value 1)
(max-value 100)
(init-value (get 'framework:recent-max-count))
(init-value (preferences:get 'framework:recent-max-count))
(callback (λ (slider y)
(set 'framework:recent-max-count
(send slider get-value)))))])
(add-callback
(preferences:set 'framework:recent-max-count
(send slider get-value)))))])
(preferences:add-callback
'framework:recent-max-count
(λ (p v)
(send slider set-value v)))))
@ -732,13 +441,14 @@ the state transitions / contracts are:
(λ (family)
(let ([name (build-font-preference-symbol family)]
[font-entry (build-font-entry family)])
(set-default name
default
(cond
[(string? default) string?]
[(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
(add-callback
(preferences:set-default
name
default
(cond
[(string? default) string?]
[(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
(preferences:add-callback
name
(λ (p new-value)
(write-resource
@ -773,11 +483,11 @@ the state transitions / contracts are:
[set-edit-font
(λ (size)
(let ([delta (make-object style-delta% 'change-size size)]
[face (get pref-sym)])
[face (preferences:get pref-sym)])
(if (and (string=? face font-default-string)
family-const-pair)
(send delta set-family (cadr family-const-pair))
(send delta set-delta-face (get pref-sym)))
(send delta set-delta-face (preferences:get pref-sym)))
(send edit change-style delta 0 (send edit last-position))))]
@ -807,14 +517,14 @@ the state transitions / contracts are:
name)
fonts)])
(when new-value
(set pref-sym (list-ref fonts (car new-value)))
(set-edit-font (get font-size-pref-sym))))))]
(preferences:set pref-sym (list-ref fonts (car new-value)))
(set-edit-font (preferences:get font-size-pref-sym))))))]
[canvas (make-object editor-canvas% horiz
edit
(list 'hide-hscroll
'hide-vscroll))])
(set-edit-font (get font-size-pref-sym))
(add-callback
(set-edit-font (preferences:get font-size-pref-sym))
(preferences:add-callback
pref-sym
(λ (p new-value)
(send horiz change-children
@ -861,11 +571,11 @@ the state transitions / contracts are:
1 127
size-panel
(λ (slider evt)
(set font-size-pref-sym (send slider get-value)))
(preferences:set font-size-pref-sym (send slider get-value)))
initial-font-size)])
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
(add-callback
(preferences:add-callback
font-size-pref-sym
(λ (p value)
(for-each (λ (f) (f value)) set-edit-fonts)

6
collects/framework/private/scheme.ss
View File

@ -7,13 +7,11 @@
(lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "thread.ss")
(lib "etc.ss")
(lib "surrogate.ss")
(lib "scheme-lexer.ss" "syntax-color")
"../gui-utils.ss")
"../gui-utils.ss"
"../preferences.ss")
(import mred^

16
collects/framework/private/sig.ss
View File

@ -60,12 +60,6 @@
(define-signature panel^ extends panel-class^
())
(define-signature exn-class^
())
(define-signature exn^ extends exn-class^
((struct exn ())
(struct unknown-preference ())))
(define-signature application-class^
())
(define-signature application^ extends application-class^
@ -74,14 +68,7 @@
(define-signature preferences-class^
())
(define-signature preferences^ extends preferences-class^
(get
add-callback
set
set-default
set-un/marshall
restore-defaults
(put-preferences/gui
add-panel
add-font-panel
@ -436,7 +423,6 @@
((open (prefix application: application^))
(open (prefix version: version^))
(open (prefix color-model: color-model^))
(open (prefix exn: exn^))
(open (prefix mode: mode^))
(open (prefix exit: exit^))
(open (prefix menu: menu^))

4
collects/framework/private/text.ss
View File

@ -11,7 +11,8 @@ WARNING: printf is rebound in the body of the unit to always
(lib "match.ss")
"sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
"../preferences.ss"
(lib "mred-sig.ss" "mred")
(lib "interactive-value-port.ss" "mrlib")
(lib "list.ss")
(lib "etc.ss"))
@ -19,7 +20,6 @@ WARNING: printf is rebound in the body of the unit to always
(import mred^
[prefix icon: framework:icon^]
[prefix editor: framework:editor^]
[prefix preferences: framework:preferences^]
[prefix keymap: framework:keymap^]
[prefix color-model: framework:color-model^]
[prefix frame: framework:frame^]