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

added docs for the gui-utils and the textual preferences to the framework

Browse Source 
svn: r9503
This commit is contained in:
Robby Findler 2008-04-27 14:57:09 +00:00
parent aceb620344
commit d07eff8bce
34 changed files with 1072 additions and 1028 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

402
collects/framework/gui-utils.ss
View File

@ -1,16 +1,10 @@
#reader scribble/reader
#lang scheme/gui
(module gui-utils mzscheme
(require mzlib/class
mred
mzlib/etc
mzlib/contract
string-constants)
(define-syntax (provide/contract/docs stx)
(syntax-case stx ()
[(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))]))
(require string-constants)
(require scribble/srcdoc)
(require/doc scheme/base scribble/manual)
(define (trim-string str size)
(let ([str-size (string-length str)])
@ -119,7 +113,7 @@
(define (cancel-on-right?) (eq? (system-type) 'windows))
(define ok/cancel-buttons
(opt-lambda (parent
(lambda (parent
confirm-callback
cancel-callback
[confirm-str (string-constant ok)]
@ -152,20 +146,24 @@
(define clickback-delta (make-object style-delta% 'change-underline #t))
(define white-on-black-clickback-delta (make-object style-delta% 'change-underline #t))
(let ()
(send clickback-delta set-delta-foreground "BLUE")
(send white-on-black-clickback-delta set-delta-foreground "deepskyblue")
(void))
(define get-clickback-delta
(opt-lambda ([white-on-black? #f])
(lambda ([white-on-black? #f])
(if white-on-black?
white-on-black-clickback-delta
clickback-delta)))
(define clicked-clickback-delta (make-object style-delta%))
(define white-on-black-clicked-clickback-delta (make-object style-delta%))
(let ()
(send clicked-clickback-delta set-delta-background "BLACK")
(send white-on-black-clicked-clickback-delta set-delta-background "white")
(void))
(define get-clicked-clickback-delta
(opt-lambda ([white-on-black? #f])
(lambda ([white-on-black? #f])
(if white-on-black?
white-on-black-clicked-clickback-delta
clicked-clickback-delta)))
@ -186,7 +184,7 @@
[(v) (set! x v) x])))
(define show-busy-cursor
(opt-lambda (thunk [delay (cursor-delay)])
(lambda (thunk [delay (cursor-delay)])
(local-busy-cursor #f thunk delay)))
(define delay-action
@ -234,7 +232,7 @@
(λ () (cursor-off))))])))
(define unsaved-warning
(opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
(lambda (filename action-anyway (can-save-now? #f) (parent #f))
(let ([mb-res (message-box/custom
(string-constant warning)
(format (string-constant file-is-not-saved) filename)
@ -252,7 +250,7 @@
[(3) 'continue]))))
(define get-choice
(opt-lambda (message
(lambda (message
true-choice
false-choice
(title (string-constant warning))
@ -294,165 +292,163 @@
(define gui-utils:cursor-delay cursor-delay)
(provide/contract/docs
(gui-utils:trim-string
(string?
(and/c number? positive?)
. ->d .
(λ (str size)
(and/c string?
(provide/doc
(proc-doc
gui-utils:trim-string
(->d ([str string?][size (and/c number? positive?)])
()
[_ (and/c string?
(λ (str)
((string-length str) . <= . size)))))
(str size)
"Constructs a string whose size is less"
"than \\var{size} by trimming the \\var{str}"
"and inserting an ellispses into it.")
((string-length str) . <= . size)))])
@{Constructs a string whose size is less
than @scheme[size] by trimming the @scheme[str]
and inserting an ellispses into it.})
(gui-utils:quote-literal-label
(string?
. ->d .
(proc-doc
gui-utils:quote-literal-label
(->d ([str string?])
()
[_ (and/c string?
(lambda (str)
(and/c string?
(lambda (str)
((string-length str) . <= . 200)))))
"Constructs a string whose ampersand characters are"
"escaped; the label is also trimmed to <= 200"
"characters.")
((string-length str) . <= . 200)))])
@{Constructs a string whose ampersand characters are
escaped; the label is also trimmed to <= 200
characters.})
(gui-utils:format-literal-label
((string?)
(listof any/c)
. ->d* .
(lambda (str . rest)
(and/c string?
(proc-doc
gui-utils:format-literal-label
(->d ([str string?])
()
#:rest rest (listof any/c)
[_ (and/c string?
(lambda (str)
((string-length str) . <= . 200)))))
"Formats a string whose ampersand characters are"
"escaped; the label is also trimmed to <= 200"
"characters.")
((string-length str) . <= . 200)))])
@{Formats a string whose ampersand characters are
escaped; the label is also trimmed to <= 200
characters.})
(gui-utils:cancel-on-right?
(proc-doc/names
gui-utils:cancel-on-right?
(-> boolean?)
()
"Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
"in a dialog and \\scheme{#f} otherwise."
""
"See also"
"@flink gui-utils:ok/cancel-buttons %"
".")
(gui-utils:ok/cancel-buttons
(opt->*
((is-a?/c area-container<%>)
@{Returns @scheme[#t] if cancel should be on the right-hand side (or below)
in a dialog and @scheme[#f] otherwise.
See also @scheme[gui-utils:ok/cancel-buttons].})
(proc-doc/names
gui-utils:ok/cancel-buttons
(->* ((is-a?/c area-container<%>)
((is-a?/c button%) (is-a?/c event%) . -> . any)
((is-a?/c button%) (is-a?/c event%) . -> . any))
(string?
string?)
((is-a?/c button%)
(values (is-a?/c button%)
(is-a?/c button%)))
((parent
confirm-callback
cancel-callback)
((confirm-label (string-constant ok))
(cancel-label (string-constant cancel))))
"Adds an Ok and a cancel button to a panel, changing the order"
"to suit the platform. Under \\MacOSBoth{} and unix, the confirmation action"
"is on the right (or bottom) and under Windows, the canceling action is on the"
"right (or bottom)."
"The confirmation action button has the \\scheme|'(border)| style."
"The buttons are also sized to be the same width."
""
"The first result is be the OK button and the second is"
"the cancel button."
""
"See also"
"@flink gui-utils:cancel-on-right? %"
".")
@{Adds an Ok and a cancel button to a panel, changing the order
to suit the platform. Under Mac OS X and unix, the confirmation action
is on the right (or bottom) and under Windows, the canceling action is on the
right (or bottom).
The confirmation action button has the @scheme['(border)] style.
The buttons are also sized to be the same width.
(gui-utils:next-untitled-name
The first result is be the OK button and the second is
the cancel button.
See also @scheme[gui-utils:cancel-on-right?].})
(proc-doc/names
gui-utils:next-untitled-name
(-> string?)
()
"Returns a name for the next opened untitled frame. The first"
"name is ``Untitled'', the second is ``Untitled 2'',"
"the third is ``Untitled 3'', and so forth.")
(gui-utils:cursor-delay
@{Returns a name for the next opened untitled frame. The first
name is ``Untitled'', the second is ``Untitled 2'',
the third is ``Untitled 3'', and so forth.})
(proc-doc/names
gui-utils:cursor-delay
(case->
(-> real?)
(real? . -> . void?))
(() (new-delay))
"This function is {\\em not\\/} a parameter."
"Instead, the state is just stored in the closure."
""
"The first case in the case lambda"
"returns the current delay in seconds before a watch cursor is shown,"
"when either \\iscmprocedure{gui-utils:local-busy-cursor} or"
"\\iscmprocedure{gui-utils:show-busy-cursor} is called."
@{This function is @italic{not} a parameter.
Instead, the state is just stored in the closure.
"The second case in the case lambda"
"Sets the delay, in seconds, before a watch cursor is shown, when"
"either \\iscmprocedure{gui-utils:local-busy-cursor} or"
"\\iscmprocedure{gui-utils:show-busy-cursor} is called.")
(gui-utils:show-busy-cursor
(opt->
((-> any/c))
The first case in the case lambda
returns the current delay in seconds before a watch cursor is shown,
when either @scheme[gui-utils:local-busy-cursor] or
@scheme[gui-utils:show-busy-cursor] is called.
The second case in the case lambda
Sets the delay, in seconds, before a watch cursor is shown, when
either @scheme[gui-utils:local-busy-cursor] or
@scheme[gui-utils:show-busy-cursor] is called.})
(proc-doc/names
gui-utils:show-busy-cursor
(->* ((-> any/c))
(integer?)
any/c)
((thunk)
((delay (gui-utils:cursor-delay))))
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument"
"\\var{delay} specifies the amount of time before the watch cursor is"
"opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value"
"to all calls."
""
"This function returns the result of \\var{thunk}.")
(gui-utils:delay-action
@{Evaluates @scheme[(thunk)] with a watch cursor. The argument
@scheme[delay] specifies the amount of time before the watch cursor is
opened. Use @scheme[gui-utils:cursor-delay] to set this value
to all calls.
This function returns the result of @scheme[thunk].})
(proc-doc/names
gui-utils:delay-action
(real?
(-> void?)
(-> void?)
. -> .
void?)
(delay-time open close)
"Use this function to delay an action for some period of time. It also"
"supports cancelling the action before the time period elapses. For"
"example, if you want to display a watch cursor, but you only want it"
"to appear after 2 seconds and the action may or may not take more than"
"two seconds, use this pattern:"
""
"\\begin{schemedisplay}"
"(let ([close-down"
" (gui-utils:delay-action"
" 2"
" (λ () .. init watch cursor ...)"
" (λ () .. close watch cursor ...))])"
" ;; .. do action ..."
" (close-down))"
"\\end{schemedisplay}"
""
"Creates a thread that waits \\var{delay-time}. After \\var{delay-time}"
"has elapsed, if the result thunk has {\\em not} been called, call"
"\\var{open}. Then, when the result thunk is called, call"
"\\var{close}. The function \\var{close} will only be called if"
"\\var{open} has been called.")
@{Use this function to delay an action for some period of time. It also
supports cancelling the action before the time period elapses. For
example, if you want to display a watch cursor, but you only want it
to appear after 2 seconds and the action may or may not take more than
two seconds, use this pattern:
(gui-utils:local-busy-cursor
(opt->
@schemeblock[
(let ([close-down
(gui-utils:delay-action
2
(λ () .. init watch cursor ...)
(λ () .. close watch cursor ...))])
;; .. do action ...
(close-down))]
Creates a thread that waits @scheme[delay-time]. After @scheme[delay-time]
has elapsed, if the result thunk has @italic{not} been called, call
@scheme[open]. Then, when the result thunk is called, call
@scheme[close]. The function @scheme[close] will only be called if
@scheme[open] has been called.})
(proc-doc/names
gui-utils:local-busy-cursor
(->*
((is-a?/c window<%>)
(-> any/c))
(integer?)
any/c)
((window thunk)
((delay (gui-utils:cursor-delay))))
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If"
"\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The"
"argument \\var{delay} specifies the amount of time before the watch"
"cursor is opened. Use "
"@flink gui-utils:cursor-delay "
"to set this value for all uses of this function."
""
"The result of this function is the result of \\var{thunk}.")
@{Evaluates @scheme[(thunk)] with a watch cursor in @scheme[window]. If
@scheme[window] is @scheme[#f], the watch cursor is turned on globally. The
argument @scheme[delay] specifies the amount of time before the watch
cursor is opened. Use
@scheme[gui-utils:cursor-delay]
to set this value for all uses of this function.
(gui-utils:unsaved-warning
(opt->
The result of this function is the result of @scheme[thunk].})
(proc-doc/names
gui-utils:unsaved-warning
(->*
(string?
string?)
(boolean?
@ -464,19 +460,19 @@
((can-save-now? #f)
(parent #f)))
"This displays a dialog that warns the user of a unsaved file."
""
"The string, \\var{action}, indicates what action is about to"
"take place, without saving. For example, if the application"
"is about to close a file, a good action is \\rawscm{\"Close"
"Anyway\"}. The result symbol indicates the user's choice. If"
"\\var{can-save-now?} is \\rawscm{\\#f}, this function does not"
"give the user the ``Save'' option and thus will not return"
"\\rawscm{'save}.")
@{This displays a dialog that warns the user of a unsaved file.
(gui-utils:get-choice
(opt->
(string?
The string, @scheme[action], indicates what action is about to
take place, without saving. For example, if the application
is about to close a file, a good action is @scheme["Close" "Anyway"].
The result symbol indicates the user's choice. If
@scheme[can-save-now?] is @scheme[#f], this function does not
give the user the ``Save'' option and thus will not return
@scheme['save].})
(proc-doc/names
gui-utils:get-choice
(->* (string?
string?
string?)
(string?
@ -495,74 +491,70 @@
(checkbox-proc #f)
(checkbox-label (string-constant dont-ask-again))))
"Opens a dialog that presents a binary choice to the user. The user is forced"
"to choose between these two options, ie cancelling or closing the dialog"
"opens a message box asking the user to actually choose one of the two options."
""
"The dialog will contain the string \\var{message} and two buttons,"
"labeled with the \\var{true-choice} and the \\var{false-choice}. If the"
"user clicks on \\var{true-choice} \\rawscm{\\#t} is returned. If the user"
"clicks on \\var{false-choice}, \\rawscm{\\#f} is returned."
""
"The argument \\var{default-result} determines how closing the window is"
"treated. If the argument is \\rawscm{'disallow-close}, closing the window"
"is not allowed. If it is anything else, that value is returned when"
"the user closes the window."
""
"If "
"@flink gui-utils:cancel-on-right?"
"returns \\scheme|#t|, the false choice is on the right."
"Otherwise, the true choice is on the right."
""
"The \\var{style} parameter is (eventually) passed to"
"@link message"
"as an icon in the dialog."
""
"If \\var{checkbox-proc} is given, it should be a procedure that behaves"
"like a parameter for getting/setting a boolean value. The intention for"
"this value is that it can be used to disable the dialog. When it is"
"given, a checkbox will appear with a \\var{checkbox-label} label"
"(defaults to the \\rawscm{dont-ask-again} string constant), and that"
"checkbox value will be sent to the \\var{checkbox-proc} when the dialog"
"is closed. Note that the dialog will always pop-up --- it is the"
"caller's responsibility to avoid the dialog if not needed.")
@{Opens a dialog that presents a binary choice to the user. The user is forced
to choose between these two options, ie cancelling or closing the dialog
opens a message box asking the user to actually choose one of the two options.
(gui-utils:get-clicked-clickback-delta
(opt->
()
The dialog will contain the string @scheme[message] and two buttons,
labeled with the @scheme[true-choice] and the @scheme[false-choice]. If the
user clicks on @scheme[true-choice] @scheme[#t] is returned. If the user
clicks on @scheme[false-choice], @scheme[#f] is returned.
The argument @scheme[default-result] determines how closing the window is
treated. If the argument is @scheme['disallow-close], closing the window
is not allowed. If it is anything else, that value is returned when
the user closes the window.
If
@scheme[gui-utils:cancel-on-right?]
returns @scheme[#t], the false choice is on the right.
Otherwise, the true choice is on the right.
The @scheme[style] parameter is (eventually) passed to
@scheme[message]
as an icon in the dialog.
If @scheme[checkbox-proc] is given, it should be a procedure that behaves
like a parameter for getting/setting a boolean value. The intention for
this value is that it can be used to disable the dialog. When it is
given, a checkbox will appear with a @scheme[checkbox-label] label
(defaults to the @scheme[dont-ask-again] string constant), and that
checkbox value will be sent to the @scheme[checkbox-proc] when the dialog
is closed. Note that the dialog will always pop-up --- it is the
caller's responsibility to avoid the dialog if not needed.})
(proc-doc/names
gui-utils:get-clicked-clickback-delta
(->* ()
(boolean?)
(is-a?/c style-delta%))
(()
((white-on-black? #f)))
"This delta is designed for use with"
"@link text set-clickback %"
". Use it as one of the \\iscmclass{style-delta} argument to"
"@link text set-clickback %"
"."
""
"If \\var{white-on-black?} is true, the function returns"
"a delta suitable for use on a black background."
""
"See also"
"@flink gui-utils:get-clickback-delta %"
".")
@{This delta is designed for use with
@method[text set-clickback].
Use it as one of the @scheme[style-delta%] argument to
@method[text% set-clickback].
(gui-utils:get-clickback-delta
(opt->
()
If @scheme[white-on-black?] is true, the function returns
a delta suitable for use on a black background.
See also @scheme[gui-utils:get-clickback-delta].})
(proc-doc/names
gui-utils:get-clickback-delta
(->* ()
(boolean?)
(is-a?/c style-delta%))
(()
((white-on-black? #f)))
"This delta is designed for use with"
"@link text set-clickback %"
". Use the result of this function as the style"
"for the region"
"text where the clickback is set."
""
"If \\var{white-on-black?} is true, the function returns"
"a delta suitable for use on a black background."
""
"See also"
"@flink gui-utils:get-clicked-clickback-delta %"
".")))
@{This delta is designed for use with
@method[text% set-clickback].
Use the result of this function as the style
for the region
text where the clickback is set.
If @scheme[white-on-black?] is true, the function returns
a delta suitable for use on a black background.
See also
@scheme[gui-utils:get-clicked-clickback-delta].}))

332
collects/framework/preferences.ss
View File

@ -1,4 +1,5 @@
#reader scribble/reader
#lang scheme/gui
#|
There are three attributes for each preference:
@ -26,10 +27,8 @@ the state transitions / contracts are:
|#
(module preferences mzscheme
(require mzlib/file
mzlib/etc
mzlib/contract)
(require scribble/srcdoc)
(require/doc scheme/base scribble/manual)
(provide exn:struct:unknown-preference)
@ -39,39 +38,33 @@ the state transitions / contracts are:
(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))
(define old-preferences (make-hasheq))
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(for-each
(λ (line) (hash-table-put! old-preferences (car line) (cadr line)))
(λ (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-hash-table))
(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-hash-table))
(define marshalled (make-hasheq))
;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hash-table))
(define marshall-unmarshall (make-hasheq))
;; callbacks : sym -o> (listof (sym TST -> boolean))
(define callbacks (make-hash-table))
(define callbacks (make-hasheq))
;; defaults : hash-table[sym -o> default]
(define defaults (make-hash-table))
(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))
@ -104,24 +97,24 @@ the state transitions / contracts are:
(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))
(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-put! preferences p (unmarshall-pref p (hash-table-get old-preferences p)))))
(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-table-remove! 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-table-put! preferences p (default-value (hash-table-get defaults p))))
(hash-set! preferences p (default-value (hash-ref defaults p))))
(hash-table-get preferences p)]
(hash-ref preferences p)]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:get
@ -142,13 +135,13 @@ the state transitions / contracts are:
(λ (p value)
(cond
[(pref-default-set? p)
(let ([default (hash-table-get defaults 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-table-put! preferences p value)
(hash-set! preferences p value)
(void))]
[(not (pref-default-set? p))
(raise-unknown-preference-error
@ -174,31 +167,31 @@ the state transitions / contracts are:
;; 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)]
(let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
[result (if un/marshall
((un/marshall-unmarshall un/marshall) data)
data)]
[default (hash-table-get defaults p)])
[default (hash-ref 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])
(lambda (p callback [weak? #f])
(let ([new-cb (make-pref-callback (if weak?
(make-weak-box callback)
callback))])
(hash-table-put! callbacks
(hash-set! callbacks
p
(append
(hash-table-get callbacks p (λ () null))
(hash-ref callbacks p (λ () null))
(list new-cb)))
(λ ()
(hash-table-put!
(hash-set!
callbacks
p
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
(let loop ([callbacks (hash-ref callbacks p (λ () null))])
(cond
[(null? callbacks) null]
[else
@ -212,7 +205,7 @@ the state transitions / contracts are:
;; check-callbacks : sym val -> void
(define (check-callbacks p value)
(let ([new-callbacks
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
(let loop ([callbacks (hash-ref callbacks p (λ () null))])
(cond
[(null? callbacks) null]
[else
@ -230,15 +223,15 @@ the state transitions / contracts are:
(cb p value)
(cons callback (loop (cdr callbacks)))]))]))])
(if (null? new-callbacks)
(hash-table-remove! callbacks p)
(hash-table-put! callbacks p 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-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
(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"
@ -252,11 +245,11 @@ the state transitions / contracts are:
(define (hash-table-bound? ht s)
(let/ec k
(hash-table-get ht s (λ () (k #f)))
(hash-ref ht s (λ () (k #f)))
#t))
(define (preferences:restore-defaults)
(hash-table-for-each
(hash-for-each
defaults
(λ (p def) (preferences:set p (default-value def)))))
@ -269,12 +262,12 @@ the state transitions / contracts are:
(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))
(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-table-put! marshalled p m))))]
(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"
@ -291,14 +284,14 @@ the state transitions / contracts are:
(let/ec k
(let* ([marshaller
(un/marshall-marshall
(hash-table-get marshall-unmarshall p (λ () (k value))))])
(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-table-map defaults (λ (k v) (cons k (preferences:get k))))))
(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))
@ -306,81 +299,82 @@ the state transitions / contracts are:
(void))
(provide/contract/docs
(preferences:snapshot?
(provide/doc
(proc-doc/names
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
@{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 \\var{snapshot}."
""
"See also "
"@flink preferences:get-prefs-snapshot %"
".")
@{Restores the preferences saved in @scheme[snapshot].
(preferences:get-prefs-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 "
"@flink preferences:restore-prefs-snapshot %"
".")
@{Caches all of the current values of the preferences and returns them.
(exn:make-unknown-preference
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.")
(exn:unknown-preference?
@{Creates an unknown preference exception.})
(proc-doc/names
exn:unknown-preference?
(any/c . -> . boolean?)
(exn)
"Determines if a value is an unknown preference exn.")
@{Determines if a value is an unknown preference exn.})
(preferences:low-level-put-preferences
(parameter-doc
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|.")
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].})
(preferences:get
(proc-doc/names
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
@{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"
"@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?
@{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
@ -390,79 +384,81 @@ the state transitions / contracts are:
(-> 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
@{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"
"@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
@{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)
"\\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 %"
".")
@{@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.
(preferences:restore-defaults
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?)
()
"\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the"
"default preferences.")))
@{@scheme[(preferences:restore-defaults)]
restores the users's configuration to the
default preferences.}))

5
collects/framework/test.ss
View File

@ -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

58
collects/scribble/srcdoc.ss
View File

@ -55,23 +55,45 @@
(lambda (stx)
(syntax-case stx ()
[(_ id contract desc)
(with-syntax ([((arg ...) result)
(with-syntax ([(header result)
(syntax-case #'contract (->d -> values)
[(->d (req ...) () (values [name res] ...))
#'((req ...) (values res ...))]
#'((id req ...) (values res ...))]
[(->d (req ...) () [name res])
#'((req ...) res)]
[(-> result)
#'(() result)]
[else
#'((id req ...) res)]
[(->d (req ...) () #:rest rest rest-ctc [name res])
#'((id req ... [rest rest-ctc] (... ...)) res)]
[(->d (req ...) (one more ...) whatever)
(raise-syntax-error
#f
"unsupported procedure contract form (no argument names)"
(format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names"
(syntax->datum #'id))
stx
#'contract)]
[(->d whatever ...)
(raise-syntax-error
#f
(format "unsupported ->d contract form for ~a" (syntax->datum #'id))
stx
#'contract)]
[(-> result)
#'((id) result)]
[(-> whatever ...)
(raise-syntax-error
#f
(format "unsupported -> contract form for ~a, must use proc-doc/names if there are arguments"
(syntax->datum #'id))
stx
#'contract)]
[(id whatever ...)
(raise-syntax-error
#f
(format "unsupported ~a contract form (unable to synthesize argument names)" (syntax->datum #'id))
stx
#'contract)])])
(values
#'[id contract]
#'(defproc (id arg ...) result . desc)
#'(defproc header result . desc)
#'(scribble/manual)))])))
(define-provide/doc-transformer proc-doc/names
@ -79,7 +101,7 @@
(syntax-case stx ()
[(_ id contract names desc)
(with-syntax ([header
(syntax-case #'(contract names) (->d -> values)
(syntax-case #'(contract names) (->d -> values case->)
[((-> ctcs ... result) (arg-names ...))
(begin
(unless (= (length (syntax->list #'(ctcs ...)))
@ -102,6 +124,11 @@
[((case-> (-> doms ... rng) ...)
((args ...) ...))
(begin
(unless (= (length (syntax->list #'((doms ...) ...)))
(length (syntax->list #'((args ...) ...))))
(raise-syntax-error #f
"number of cases and number of arg lists do not have the same size"
stx))
(for-each
(λ (doms args)
(unless (= (length (syntax->list doms))
@ -125,7 +152,18 @@
(lambda (stx)
(syntax-case stx (parameter/c)
[(_ id (parameter/c contract) arg-id desc)
(begin
(unless (identifier? #'arg-id)
(raise-syntax-error 'parameter/doc
"expected an identifier"
stx
#'arg-id))
(unless (identifier? #'id)
(raise-syntax-error 'parameter/doc
"expected an identifier"
stx
#'id))
(values
#'[id (parameter/c contract)]
#'(defparam id arg-id contract . desc)
#'(scribble/manual))])))
#'(scribble/manual)))])))

0
collects/scribblings/framework/framework-application.scrbl → collects/scribblings/framework/application.scrbl
View File

0
collects/scribblings/framework/framework-autosave.scrbl → collects/scribblings/framework/autosave.scrbl
View File

0
collects/scribblings/framework/framework-canvas.scrbl → collects/scribblings/framework/canvas.scrbl
View File

0
collects/scribblings/framework/framework-color-model.scrbl → collects/scribblings/framework/color-model.scrbl
View File

0
collects/scribblings/framework/framework-color-prefs.scrbl → collects/scribblings/framework/color-prefs.scrbl
View File

0
collects/scribblings/framework/framework-color.scrbl → collects/scribblings/framework/color.scrbl
View File

0
collects/scribblings/framework/framework-comment-box.scrbl → collects/scribblings/framework/comment-box.scrbl
View File

0
collects/scribblings/framework/framework-editor.scrbl → collects/scribblings/framework/editor.scrbl
View File

0
collects/scribblings/framework/framework-exit.scrbl → collects/scribblings/framework/exit.scrbl
View File

0
collects/scribblings/framework/framework-finder.scrbl → collects/scribblings/framework/finder.scrbl
View File

0
collects/scribblings/framework/framework-frame.scrbl → collects/scribblings/framework/frame.scrbl
View File

65
collects/scribblings/framework/framework.scrbl
View File

@ -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[]

0
collects/scribblings/framework/framework-group.scrbl → collects/scribblings/framework/group.scrbl
View File

10
collects/scribblings/framework/gui-utils.scrbl Normal file
View 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"))

0
collects/scribblings/framework/framework-handler.scrbl → collects/scribblings/framework/handler.scrbl
View File

0
collects/scribblings/framework/framework-icon.scrbl → collects/scribblings/framework/icon.scrbl
View File

0
collects/scribblings/framework/framework-keymap.scrbl → collects/scribblings/framework/keymap.scrbl
View File

0
collects/scribblings/framework/framework-main.scrbl → collects/scribblings/framework/main.scrbl
View File

0
collects/scribblings/framework/framework-menu.scrbl → collects/scribblings/framework/menu.scrbl
View File

0
collects/scribblings/framework/framework-mode.scrbl → collects/scribblings/framework/mode.scrbl
View File

0
collects/scribblings/framework/framework-number-snip.scrbl → collects/scribblings/framework/number-snip.scrbl
View File

0
collects/scribblings/framework/framework-panel.scrbl → collects/scribblings/framework/panel.scrbl
View File

0
collects/scribblings/framework/framework-pasteboard.scrbl → collects/scribblings/framework/pasteboard.scrbl
View File

0
collects/scribblings/framework/framework-path-utils.scrbl → collects/scribblings/framework/path-utils.scrbl
View File

10
collects/scribblings/framework/preferences-text.scrbl Normal file
View 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"))

0
collects/scribblings/framework/framework-preferences.scrbl → collects/scribblings/framework/preferences.scrbl
View File

0
collects/scribblings/framework/framework-scheme.scrbl → collects/scribblings/framework/scheme.scrbl
View File

0
collects/scribblings/framework/framework-test.scrbl → collects/scribblings/framework/test.scrbl
View File

0
collects/scribblings/framework/framework-text.scrbl → collects/scribblings/framework/text.scrbl
View File

0
collects/scribblings/framework/framework-version.scrbl → collects/scribblings/framework/version.scrbl
View File