separated preferences library out to be used by mz
svn: r5537 original commit: 13110a2113d1a8e2174e7e381809cb90916d18bf
This commit is contained in:
Robby Findler
parent
18eb1751c2
commit
4a5976a827
|
|
@ -6,6 +6,7 @@
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
|
|
||||||
|
"preferences.ss"
|
||||||
"test.ss"
|
"test.ss"
|
||||||
"gui-utils.ss"
|
"gui-utils.ss"
|
||||||
"decorated-editor-snip.ss"
|
"decorated-editor-snip.ss"
|
||||||
|
|
@ -19,7 +20,6 @@
|
||||||
(prefix application: framework:application-class^)
|
(prefix application: framework:application-class^)
|
||||||
(prefix version: framework:version-class^)
|
(prefix version: framework:version-class^)
|
||||||
(prefix color-model: framework:color-model-class^)
|
(prefix color-model: framework:color-model-class^)
|
||||||
(prefix exn: framework:exn-class^)
|
|
||||||
(prefix mode: framework:mode-class^)
|
(prefix mode: framework:mode-class^)
|
||||||
(prefix exit: framework:exit-class^)
|
(prefix exit: framework:exit-class^)
|
||||||
(prefix menu: framework:menu-class^)
|
(prefix menu: framework:menu-class^)
|
||||||
|
|
@ -46,11 +46,9 @@
|
||||||
|
|
||||||
(provide (all-from "test.ss")
|
(provide (all-from "test.ss")
|
||||||
(all-from "gui-utils.ss")
|
(all-from "gui-utils.ss")
|
||||||
|
(all-from "preferences.ss")
|
||||||
(all-from "decorated-editor-snip.ss"))
|
(all-from "decorated-editor-snip.ss"))
|
||||||
|
|
||||||
(provide exn:struct:unknown-preference
|
|
||||||
exn:struct:exn)
|
|
||||||
|
|
||||||
(define-syntax (provide/contract/docs stx)
|
(define-syntax (provide/contract/docs stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (name contract docs ...) ...)
|
[(_ (name contract docs ...) ...)
|
||||||
|
|
@ -107,23 +105,6 @@
|
||||||
"@flink version:add-spec %"
|
"@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
|
(application:current-app-name
|
||||||
(case-> (-> string?)
|
(case-> (-> string?)
|
||||||
(string? . -> . void?))
|
(string? . -> . void?))
|
||||||
|
|
@ -137,116 +118,6 @@
|
||||||
"the second case in the case-lambda sets"
|
"the second case in the case-lambda sets"
|
||||||
"the name of the application to \\var{name}.")
|
"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
|
(preferences:add-panel
|
||||||
((or/c string? (cons/c string? (listof string?)))
|
((or/c string? (cons/c string? (listof string?)))
|
||||||
((is-a?/c area-container-window<%>)
|
((is-a?/c area-container-window<%>)
|
||||||
|
|
|
||||||
|
|
@ -4,15 +4,13 @@
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "mred.ss" "mred") ;; remove this!
|
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants"))
|
||||||
(lib "unit.ss"))
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix exit: framework:exit^]
|
[prefix exit: framework:exit^]
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
[prefix scheme: framework:scheme^]
|
[prefix scheme: framework:scheme^]
|
||||||
[prefix editor: framework:editor^]
|
[prefix editor: framework:editor^]
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
(module canvas (lib "a-unit.ss")
|
(module canvas (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
[prefix text: framework:text^])
|
[prefix text: framework:text^])
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
(module color-prefs (lib "a-unit.ss")
|
(module color-prefs (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "unit.ss")
|
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants")
|
||||||
|
"../preferences.ss"
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
(import [prefix preferences: framework:preferences^]
|
(import [prefix preferences: framework:preferences^]
|
||||||
|
|
|
||||||
|
|
@ -1,16 +1,15 @@
|
||||||
(module color (lib "a-unit.ss")
|
(module color (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "etc.ss")
|
|
||||||
(lib "thread.ss")
|
(lib "thread.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
|
(lib "etc.ss")
|
||||||
(lib "token-tree.ss" "syntax-color")
|
(lib "token-tree.ss" "syntax-color")
|
||||||
(lib "paren-tree.ss" "syntax-color")
|
(lib "paren-tree.ss" "syntax-color")
|
||||||
(lib "default-lexer.ss" "syntax-color")
|
(lib "default-lexer.ss" "syntax-color")
|
||||||
(lib "unit.ss")
|
"../preferences.ss"
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
(import [prefix preferences: framework:preferences^]
|
(import [prefix icon: framework:icon^]
|
||||||
[prefix icon: framework:icon^]
|
|
||||||
[prefix mode: framework:mode^]
|
[prefix mode: framework:mode^]
|
||||||
[prefix text: framework:text^]
|
[prefix text: framework:text^]
|
||||||
[prefix color-prefs: framework:color-prefs^]
|
[prefix color-prefs: framework:color-prefs^]
|
||||||
|
|
|
||||||
|
|
@ -3,6 +3,7 @@
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
|
|
@ -14,7 +15,6 @@
|
||||||
[prefix path-utils: framework:path-utils^]
|
[prefix path-utils: framework:path-utils^]
|
||||||
[prefix keymap: framework:keymap^]
|
[prefix keymap: framework:keymap^]
|
||||||
[prefix icon: framework:icon^]
|
[prefix icon: framework:icon^]
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix text: framework:text^]
|
[prefix text: framework:text^]
|
||||||
[prefix pasteboard: framework:pasteboard^]
|
[prefix pasteboard: framework:pasteboard^]
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
|
|
|
||||||
|
|
@ -1,14 +1,11 @@
|
||||||
(module exit (lib "a-unit.ss")
|
(module exit (lib "a-unit.ss")
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
(lib "class.ss")
|
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred"))
|
||||||
(lib "file.ss")
|
|
||||||
(lib "etc.ss"))
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^)
|
||||||
[prefix preferences: framework:preferences^])
|
|
||||||
(export (rename framework:exit^
|
(export (rename framework:exit^
|
||||||
(-exit exit)))
|
(-exit exit)))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,17 +2,14 @@
|
||||||
(module finder (lib "a-unit.ss")
|
(module finder (lib "a-unit.ss")
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../preferences.ss"
|
||||||
(lib "class.ss")
|
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "list.ss")
|
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "etc.ss"))
|
(lib "etc.ss"))
|
||||||
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix keymap: framework:keymap^])
|
[prefix keymap: framework:keymap^])
|
||||||
|
|
||||||
(export (rename framework:finder^
|
(export (rename framework:finder^
|
||||||
|
|
|
||||||
|
|
@ -4,6 +4,7 @@
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "include.ss")
|
(lib "include.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
"bday.ss"
|
"bday.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
|
|
|
||||||
|
|
@ -3,6 +3,7 @@
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
|
|
@ -11,7 +12,6 @@
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix application: framework:application^]
|
[prefix application: framework:application^]
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix text: framework:text^]
|
[prefix text: framework:text^]
|
||||||
[prefix canvas: framework:canvas^]
|
[prefix canvas: framework:canvas^]
|
||||||
[prefix menu: framework:menu^])
|
[prefix menu: framework:menu^])
|
||||||
|
|
|
||||||
|
|
@ -4,6 +4,7 @@
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "hierlist.ss" "hierlist")
|
(lib "hierlist.ss" "hierlist")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
|
|
@ -14,7 +15,6 @@
|
||||||
[prefix finder: framework:finder^]
|
[prefix finder: framework:finder^]
|
||||||
[prefix group: framework:group^]
|
[prefix group: framework:group^]
|
||||||
[prefix text: framework:text^]
|
[prefix text: framework:text^]
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix frame: framework:frame^])
|
[prefix frame: framework:frame^])
|
||||||
(export framework:handler^)
|
(export framework:handler^)
|
||||||
(init-depend framework:frame^)
|
(init-depend framework:frame^)
|
||||||
|
|
|
||||||
|
|
@ -5,11 +5,11 @@
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "match.ss")
|
(lib "match.ss")
|
||||||
|
"../preferences.ss"
|
||||||
"sig.ss")
|
"sig.ss")
|
||||||
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix finder: framework:finder^]
|
[prefix finder: framework:finder^]
|
||||||
[prefix handler: framework:handler^]
|
[prefix handler: framework:handler^]
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,7 @@
|
||||||
(module main (lib "a-unit.ss")
|
(module main (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../preferences.ss"
|
||||||
(lib "string-constant.ss" "string-constants")
|
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
|
|
@ -17,6 +16,8 @@
|
||||||
(init-depend framework:preferences^ framework:exit^ framework:editor^
|
(init-depend framework:preferences^ framework:exit^ framework:editor^
|
||||||
framework:color-prefs^ framework:scheme^)
|
framework:color-prefs^ framework:scheme^)
|
||||||
|
|
||||||
|
(preferences:low-level-put-preferences preferences:put-preferences/gui)
|
||||||
|
|
||||||
(application-preferences-handler (λ () (preferences:show-dialog)))
|
(application-preferences-handler (λ () (preferences:show-dialog)))
|
||||||
|
|
||||||
(preferences:set-default 'framework:square-bracket:cond/offset
|
(preferences:set-default 'framework:square-bracket:cond/offset
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
(module menu (lib "a-unit.ss")
|
(module menu (lib "a-unit.ss")
|
||||||
(require (lib "class.ss")
|
(require (lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred"))
|
(lib "mred-sig.ss" "mred"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^)
|
||||||
[prefix preferences: framework:preferences^])
|
|
||||||
(export framework:menu^)
|
(export framework:menu^)
|
||||||
|
|
||||||
(define can-restore<%>
|
(define can-restore<%>
|
||||||
|
|
|
||||||
|
|
@ -3,10 +3,10 @@
|
||||||
(require "sig.ss"
|
(require "sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
|
"../preferences.ss"
|
||||||
(lib "string-constant.ss" "string-constants"))
|
(lib "string-constant.ss" "string-constants"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^)
|
||||||
[prefix preferences: framework:preferences^])
|
|
||||||
(export (rename framework:number-snip^
|
(export (rename framework:number-snip^
|
||||||
[-snip-class% snip-class%]))
|
[-snip-class% snip-class%]))
|
||||||
(init-depend mred^)
|
(init-depend mred^)
|
||||||
|
|
|
||||||
|
|
@ -30,139 +30,18 @@ the state transitions / contracts are:
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "file.ss")
|
(lib "file.ss")
|
||||||
(lib "etc.ss")
|
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "pretty.ss")
|
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix exn: framework:exn^]
|
|
||||||
[prefix exit: framework:exit^]
|
[prefix exit: framework:exit^]
|
||||||
[prefix panel: framework:panel^]
|
[prefix panel: framework:panel^]
|
||||||
[prefix frame: framework:frame^])
|
[prefix frame: framework:frame^])
|
||||||
(export framework:preferences^)
|
(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 (put-preferences/gui ps vs)
|
||||||
(define (fail-func path)
|
(define (fail-func path)
|
||||||
(let ([mb-ans
|
(let ([mb-ans
|
||||||
|
|
@ -197,177 +76,6 @@ the state transitions / contracts are:
|
||||||
vs
|
vs
|
||||||
fail-func)))
|
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 =
|
;; ppanel-tree =
|
||||||
|
|
@ -465,12 +173,12 @@ the state transitions / contracts are:
|
||||||
(define can-close-dialog-callbacks null)
|
(define can-close-dialog-callbacks null)
|
||||||
|
|
||||||
(define (make-preferences-dialog)
|
(define (make-preferences-dialog)
|
||||||
(letrec ([stashed-prefs (get-prefs-snapshot)]
|
(letrec ([stashed-prefs (preferences:get-prefs-snapshot)]
|
||||||
[frame-stashed-prefs%
|
[frame-stashed-prefs%
|
||||||
(class frame:basic%
|
(class frame:basic%
|
||||||
(define/override (show on?)
|
(define/override (show on?)
|
||||||
(when on?
|
(when on?
|
||||||
(set! stashed-prefs (get-prefs-snapshot)))
|
(set! stashed-prefs (preferences:get-prefs-snapshot)))
|
||||||
(super show on?))
|
(super show on?))
|
||||||
(super-new))]
|
(super-new))]
|
||||||
[frame
|
[frame
|
||||||
|
|
@ -529,7 +237,7 @@ the state transitions / contracts are:
|
||||||
(hide-dialog)))]
|
(hide-dialog)))]
|
||||||
[cancel-callback (λ (_1 _2)
|
[cancel-callback (λ (_1 _2)
|
||||||
(hide-dialog)
|
(hide-dialog)
|
||||||
(restore-prefs-snapshot stashed-prefs))])
|
(preferences:restore-prefs-snapshot stashed-prefs))])
|
||||||
(gui-utils:ok/cancel-buttons
|
(gui-utils:ok/cancel-buttons
|
||||||
bottom-panel
|
bottom-panel
|
||||||
ok-callback
|
ok-callback
|
||||||
|
|
@ -574,12 +282,13 @@ the state transitions / contracts are:
|
||||||
(define (make-check main pref title bool->pref pref->bool)
|
(define (make-check main pref title bool->pref pref->bool)
|
||||||
(let* ([callback
|
(let* ([callback
|
||||||
(λ (check-box _)
|
(λ (check-box _)
|
||||||
(set pref (bool->pref (send check-box get-value))))]
|
(preferences:set pref (bool->pref (send check-box get-value))))]
|
||||||
[pref-value (get pref)]
|
[pref-value (preferences:get pref)]
|
||||||
[initial-value (pref->bool pref-value)]
|
[initial-value (pref->bool pref-value)]
|
||||||
[c (make-object check-box% title main callback)])
|
[c (make-object check-box% title main callback)])
|
||||||
(send c set-value initial-value)
|
(send c set-value initial-value)
|
||||||
(add-callback pref
|
(preferences:add-callback
|
||||||
|
pref
|
||||||
(λ (p v)
|
(λ (p v)
|
||||||
(send c set-value (pref->bool v))))))
|
(send c set-value (pref->bool v))))))
|
||||||
|
|
||||||
|
|
@ -589,11 +298,11 @@ the state transitions / contracts are:
|
||||||
(label (string-constant number-of-open-recent-items))
|
(label (string-constant number-of-open-recent-items))
|
||||||
(min-value 1)
|
(min-value 1)
|
||||||
(max-value 100)
|
(max-value 100)
|
||||||
(init-value (get 'framework:recent-max-count))
|
(init-value (preferences:get 'framework:recent-max-count))
|
||||||
(callback (λ (slider y)
|
(callback (λ (slider y)
|
||||||
(set 'framework:recent-max-count
|
(preferences:set 'framework:recent-max-count
|
||||||
(send slider get-value)))))])
|
(send slider get-value)))))])
|
||||||
(add-callback
|
(preferences:add-callback
|
||||||
'framework:recent-max-count
|
'framework:recent-max-count
|
||||||
(λ (p v)
|
(λ (p v)
|
||||||
(send slider set-value v)))))
|
(send slider set-value v)))))
|
||||||
|
|
@ -732,13 +441,14 @@ the state transitions / contracts are:
|
||||||
(λ (family)
|
(λ (family)
|
||||||
(let ([name (build-font-preference-symbol family)]
|
(let ([name (build-font-preference-symbol family)]
|
||||||
[font-entry (build-font-entry family)])
|
[font-entry (build-font-entry family)])
|
||||||
(set-default name
|
(preferences:set-default
|
||||||
|
name
|
||||||
default
|
default
|
||||||
(cond
|
(cond
|
||||||
[(string? default) string?]
|
[(string? default) string?]
|
||||||
[(number? default) number?]
|
[(number? default) number?]
|
||||||
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
|
||||||
(add-callback
|
(preferences:add-callback
|
||||||
name
|
name
|
||||||
(λ (p new-value)
|
(λ (p new-value)
|
||||||
(write-resource
|
(write-resource
|
||||||
|
|
@ -773,11 +483,11 @@ the state transitions / contracts are:
|
||||||
[set-edit-font
|
[set-edit-font
|
||||||
(λ (size)
|
(λ (size)
|
||||||
(let ([delta (make-object style-delta% 'change-size 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)
|
(if (and (string=? face font-default-string)
|
||||||
family-const-pair)
|
family-const-pair)
|
||||||
(send delta set-family (cadr 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))))]
|
(send edit change-style delta 0 (send edit last-position))))]
|
||||||
|
|
||||||
|
|
@ -807,14 +517,14 @@ the state transitions / contracts are:
|
||||||
name)
|
name)
|
||||||
fonts)])
|
fonts)])
|
||||||
(when new-value
|
(when new-value
|
||||||
(set pref-sym (list-ref fonts (car new-value)))
|
(preferences:set pref-sym (list-ref fonts (car new-value)))
|
||||||
(set-edit-font (get font-size-pref-sym))))))]
|
(set-edit-font (preferences:get font-size-pref-sym))))))]
|
||||||
[canvas (make-object editor-canvas% horiz
|
[canvas (make-object editor-canvas% horiz
|
||||||
edit
|
edit
|
||||||
(list 'hide-hscroll
|
(list 'hide-hscroll
|
||||||
'hide-vscroll))])
|
'hide-vscroll))])
|
||||||
(set-edit-font (get font-size-pref-sym))
|
(set-edit-font (preferences:get font-size-pref-sym))
|
||||||
(add-callback
|
(preferences:add-callback
|
||||||
pref-sym
|
pref-sym
|
||||||
(λ (p new-value)
|
(λ (p new-value)
|
||||||
(send horiz change-children
|
(send horiz change-children
|
||||||
|
|
@ -861,11 +571,11 @@ the state transitions / contracts are:
|
||||||
1 127
|
1 127
|
||||||
size-panel
|
size-panel
|
||||||
(λ (slider evt)
|
(λ (slider evt)
|
||||||
(set font-size-pref-sym (send slider get-value)))
|
(preferences:set font-size-pref-sym (send slider get-value)))
|
||||||
initial-font-size)])
|
initial-font-size)])
|
||||||
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
|
||||||
(update-message-sizes category-message-get-widths category-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
|
font-size-pref-sym
|
||||||
(λ (p value)
|
(λ (p value)
|
||||||
(for-each (λ (f) (f value)) set-edit-fonts)
|
(for-each (λ (f) (f value)) set-edit-fonts)
|
||||||
|
|
|
||||||
|
|
@ -7,13 +7,11 @@
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "mred.ss" "mred")
|
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "thread.ss")
|
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "surrogate.ss")
|
|
||||||
(lib "scheme-lexer.ss" "syntax-color")
|
(lib "scheme-lexer.ss" "syntax-color")
|
||||||
"../gui-utils.ss")
|
"../gui-utils.ss"
|
||||||
|
"../preferences.ss")
|
||||||
|
|
||||||
|
|
||||||
(import mred^
|
(import mred^
|
||||||
|
|
|
||||||
|
|
@ -60,12 +60,6 @@
|
||||||
(define-signature panel^ extends panel-class^
|
(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-class^
|
||||||
())
|
())
|
||||||
(define-signature application^ extends application-class^
|
(define-signature application^ extends application-class^
|
||||||
|
|
@ -74,14 +68,7 @@
|
||||||
(define-signature preferences-class^
|
(define-signature preferences-class^
|
||||||
())
|
())
|
||||||
(define-signature preferences^ extends preferences-class^
|
(define-signature preferences^ extends preferences-class^
|
||||||
(get
|
(put-preferences/gui
|
||||||
add-callback
|
|
||||||
set
|
|
||||||
set-default
|
|
||||||
set-un/marshall
|
|
||||||
|
|
||||||
restore-defaults
|
|
||||||
|
|
||||||
add-panel
|
add-panel
|
||||||
add-font-panel
|
add-font-panel
|
||||||
|
|
||||||
|
|
@ -436,7 +423,6 @@
|
||||||
((open (prefix application: application^))
|
((open (prefix application: application^))
|
||||||
(open (prefix version: version^))
|
(open (prefix version: version^))
|
||||||
(open (prefix color-model: color-model^))
|
(open (prefix color-model: color-model^))
|
||||||
(open (prefix exn: exn^))
|
|
||||||
(open (prefix mode: mode^))
|
(open (prefix mode: mode^))
|
||||||
(open (prefix exit: exit^))
|
(open (prefix exit: exit^))
|
||||||
(open (prefix menu: menu^))
|
(open (prefix menu: menu^))
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,7 @@ WARNING: printf is rebound in the body of the unit to always
|
||||||
(lib "match.ss")
|
(lib "match.ss")
|
||||||
"sig.ss"
|
"sig.ss"
|
||||||
"../gui-utils.ss"
|
"../gui-utils.ss"
|
||||||
|
"../preferences.ss"
|
||||||
(lib "mred-sig.ss" "mred")
|
(lib "mred-sig.ss" "mred")
|
||||||
(lib "interactive-value-port.ss" "mrlib")
|
(lib "interactive-value-port.ss" "mrlib")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
|
|
@ -19,7 +20,6 @@ WARNING: printf is rebound in the body of the unit to always
|
||||||
(import mred^
|
(import mred^
|
||||||
[prefix icon: framework:icon^]
|
[prefix icon: framework:icon^]
|
||||||
[prefix editor: framework:editor^]
|
[prefix editor: framework:editor^]
|
||||||
[prefix preferences: framework:preferences^]
|
|
||||||
[prefix keymap: framework:keymap^]
|
[prefix keymap: framework:keymap^]
|
||||||
[prefix color-model: framework:color-model^]
|
[prefix color-model: framework:color-model^]
|
||||||
[prefix frame: framework:frame^]
|
[prefix frame: framework:frame^]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user