suzanne.soy/gui
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

original commit: d07eff8bceb5d1b07deb074d1e180f3f9ba713d7
This commit is contained in:
Robby Findler 2008-04-27 14:57:09 +00:00
parent 35f5253f8d
commit 45a7f4f451
33 changed files with 1021 additions and 1015 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,18 +1,12 @@
#reader scribble/reader
#lang scheme/gui
(module gui-utils mzscheme (require string-constants)
(require mzlib/class
mred
mzlib/etc
mzlib/contract
string-constants)
(define-syntax (provide/contract/docs stx) (require scribble/srcdoc)
(syntax-case stx () (require/doc scheme/base scribble/manual)
[(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))]))
(define (trim-string str size)
(define (trim-string str size)
(let ([str-size (string-length str)]) (let ([str-size (string-length str)])
(cond (cond
[(<= str-size size) [(<= str-size size)
@ -37,35 +31,35 @@
str-size))]))]))) str-size))]))])))
(define maximum-string-label-length 200) (define maximum-string-label-length 200)
;; format-literal-label: string any* -> string ;; format-literal-label: string any* -> string
(define (format-literal-label format-str . args) (define (format-literal-label format-str . args)
(quote-literal-label (apply format format-str args))) (quote-literal-label (apply format format-str args)))
;; quote-literal-label: string -> string ;; quote-literal-label: string -> string
(define (quote-literal-label a-str) (define (quote-literal-label a-str)
(trim-string (regexp-replace* #rx"(&)" a-str "\\1\\1") (trim-string (regexp-replace* #rx"(&)" a-str "\\1\\1")
maximum-string-label-length)) maximum-string-label-length))
;; selected-text-color : color ;; selected-text-color : color
(define selected-text-color (send the-color-database find-color "black")) (define selected-text-color (send the-color-database find-color "black"))
;; unselected-text-color : color ;; unselected-text-color : color
(define unselected-text-color (case (system-type) (define unselected-text-color (case (system-type)
[(macosx) (make-object color% 75 75 75)] [(macosx) (make-object color% 75 75 75)]
[else (send the-color-database find-color "black")])) [else (send the-color-database find-color "black")]))
;; selected-brush : brush ;; selected-brush : brush
(define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
;; unselected-brush : brush ;; unselected-brush : brush
(define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid)) (define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
;; button-down/over-brush : brush ;; button-down/over-brush : brush
(define button-down/over-brush (define button-down/over-brush
(case (system-type) (case (system-type)
[(macosx) (send the-brush-list find-or-create-brush [(macosx) (send the-brush-list find-or-create-brush
"light blue" "light blue"
@ -76,50 +70,50 @@
'solid)])) 'solid)]))
;; name-box-pen : pen ;; name-box-pen : pen
;; this pen draws the lines around each individual item ;; this pen draws the lines around each individual item
(define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
;; background-brush : brush ;; background-brush : brush
;; this brush is set when drawing the background for the control ;; this brush is set when drawing the background for the control
(define background-brush (define background-brush
(case (system-type) (case (system-type)
[(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)] [(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)]
[else (send the-brush-list find-or-create-brush "white" 'solid)])) [else (send the-brush-list find-or-create-brush "white" 'solid)]))
;; background-pen : pen ;; background-pen : pen
;; this pen is set when drawing the background for the control ;; this pen is set when drawing the background for the control
(define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) (define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
;; label-font : font ;; label-font : font
(define label-font (send the-font-list find-or-create-font (define label-font (send the-font-list find-or-create-font
(if (eq? (system-type) 'windows) 10 12) (if (eq? (system-type) 'windows) 10 12)
'system 'normal 'system 'normal
(if (eq? (system-type) 'macosx) 'bold 'normal) (if (eq? (system-type) 'macosx) 'bold 'normal)
#f)) #f))
;; name-gap : number ;; name-gap : number
;; the space between each name ;; the space between each name
(define name-gap 4) (define name-gap 4)
;; hang-over : number ;; hang-over : number
;; the amount of space a single entry "slants" over ;; the amount of space a single entry "slants" over
(define hang-over 8) (define hang-over 8)
;; top-space : number ;; top-space : number
;; the gap at the top of the canvas, above all the choices ;; the gap at the top of the canvas, above all the choices
(define top-space 4) (define top-space 4)
;; bottom-space : number ;; bottom-space : number
;; the extra space below the words ;; the extra space below the words
(define bottom-space 2) (define bottom-space 2)
;; end choices-canvas% ;; end choices-canvas%
(define (cancel-on-right?) (eq? (system-type) 'windows)) (define (cancel-on-right?) (eq? (system-type) 'windows))
(define ok/cancel-buttons (define ok/cancel-buttons
(opt-lambda (parent (lambda (parent
confirm-callback confirm-callback
cancel-callback cancel-callback
[confirm-str (string-constant ok)] [confirm-str (string-constant ok)]
@ -150,27 +144,31 @@
(values b2 b1))))))) (values b2 b1)))))))
(define clickback-delta (make-object style-delta% 'change-underline #t)) (define clickback-delta (make-object style-delta% 'change-underline #t))
(define white-on-black-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 clickback-delta set-delta-foreground "BLUE")
(send white-on-black-clickback-delta set-delta-foreground "deepskyblue") (send white-on-black-clickback-delta set-delta-foreground "deepskyblue")
(define get-clickback-delta (void))
(opt-lambda ([white-on-black? #f]) (define get-clickback-delta
(lambda ([white-on-black? #f])
(if white-on-black? (if white-on-black?
white-on-black-clickback-delta white-on-black-clickback-delta
clickback-delta))) clickback-delta)))
(define clicked-clickback-delta (make-object style-delta%)) (define clicked-clickback-delta (make-object style-delta%))
(define white-on-black-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 clicked-clickback-delta set-delta-background "BLACK")
(send white-on-black-clicked-clickback-delta set-delta-background "white") (send white-on-black-clicked-clickback-delta set-delta-background "white")
(define get-clicked-clickback-delta (void))
(opt-lambda ([white-on-black? #f]) (define get-clicked-clickback-delta
(lambda ([white-on-black? #f])
(if white-on-black? (if white-on-black?
white-on-black-clicked-clickback-delta white-on-black-clicked-clickback-delta
clicked-clickback-delta))) clicked-clickback-delta)))
(define next-untitled-name (define next-untitled-name
(let ([n 1]) (let ([n 1])
(λ () (λ ()
(begin0 (begin0
@ -179,17 +177,17 @@
[else (format (string-constant untitled-n) n)]) [else (format (string-constant untitled-n) n)])
(set! n (+ n 1)))))) (set! n (+ n 1))))))
(define cursor-delay (define cursor-delay
(let ([x 0.25]) (let ([x 0.25])
(case-lambda (case-lambda
[() x] [() x]
[(v) (set! x v) x]))) [(v) (set! x v) x])))
(define show-busy-cursor (define show-busy-cursor
(opt-lambda (thunk [delay (cursor-delay)]) (lambda (thunk [delay (cursor-delay)])
(local-busy-cursor #f thunk delay))) (local-busy-cursor #f thunk delay)))
(define delay-action (define delay-action
(λ (delay-time open close) (λ (delay-time open close)
(let ([semaphore (make-semaphore 1)] (let ([semaphore (make-semaphore 1)]
[open? #f] [open? #f]
@ -209,7 +207,7 @@
(close)) (close))
(semaphore-post semaphore))))) (semaphore-post semaphore)))))
(define local-busy-cursor (define local-busy-cursor
(let ([watch (make-object cursor% 'watch)]) (let ([watch (make-object cursor% 'watch)])
(case-lambda (case-lambda
[(win thunk) (local-busy-cursor win thunk (cursor-delay))] [(win thunk) (local-busy-cursor win thunk (cursor-delay))]
@ -233,8 +231,8 @@
(λ () (thunk)) (λ () (thunk))
(λ () (cursor-off))))]))) (λ () (cursor-off))))])))
(define unsaved-warning (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 (let ([mb-res (message-box/custom
(string-constant warning) (string-constant warning)
(format (string-constant file-is-not-saved) filename) (format (string-constant file-is-not-saved) filename)
@ -251,8 +249,8 @@
[(2) 'cancel] [(2) 'cancel]
[(3) 'continue])))) [(3) 'continue]))))
(define get-choice (define get-choice
(opt-lambda (message (lambda (message
true-choice true-choice
false-choice false-choice
(title (string-constant warning)) (title (string-constant warning))
@ -277,182 +275,180 @@
(return (message-box/custom title message true-choice false-choice #f (return (message-box/custom title message true-choice false-choice #f
parent style default-result)))))) parent style default-result))))))
;; manual renaming ;; manual renaming
(define gui-utils:trim-string trim-string) (define gui-utils:trim-string trim-string)
(define gui-utils:quote-literal-label quote-literal-label) (define gui-utils:quote-literal-label quote-literal-label)
(define gui-utils:format-literal-label format-literal-label) (define gui-utils:format-literal-label format-literal-label)
(define gui-utils:next-untitled-name next-untitled-name) (define gui-utils:next-untitled-name next-untitled-name)
(define gui-utils:show-busy-cursor show-busy-cursor) (define gui-utils:show-busy-cursor show-busy-cursor)
(define gui-utils:delay-action delay-action) (define gui-utils:delay-action delay-action)
(define gui-utils:local-busy-cursor local-busy-cursor) (define gui-utils:local-busy-cursor local-busy-cursor)
(define gui-utils:unsaved-warning unsaved-warning) (define gui-utils:unsaved-warning unsaved-warning)
(define gui-utils:get-choice get-choice) (define gui-utils:get-choice get-choice)
(define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta) (define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
(define gui-utils:get-clickback-delta get-clickback-delta) (define gui-utils:get-clickback-delta get-clickback-delta)
(define gui-utils:ok/cancel-buttons ok/cancel-buttons) (define gui-utils:ok/cancel-buttons ok/cancel-buttons)
(define gui-utils:cancel-on-right? cancel-on-right?) (define gui-utils:cancel-on-right? cancel-on-right?)
(define gui-utils:cursor-delay cursor-delay) (define gui-utils:cursor-delay cursor-delay)
(provide/contract/docs (provide/doc
(proc-doc
(gui-utils:trim-string gui-utils:trim-string
(string? (->d ([str string?][size (and/c number? positive?)])
(and/c number? positive?) ()
. ->d . [_ (and/c string?
(λ (str size)
(and/c string?
(λ (str) (λ (str)
((string-length str) . <= . size))))) ((string-length str) . <= . size)))])
(str size) @{Constructs a string whose size is less
"Constructs a string whose size is less" than @scheme[size] by trimming the @scheme[str]
"than \\var{size} by trimming the \\var{str}" and inserting an ellispses into it.})
"and inserting an ellispses into it.")
(gui-utils:quote-literal-label (proc-doc
(string? gui-utils:quote-literal-label
. ->d . (->d ([str string?])
()
[_ (and/c string?
(lambda (str) (lambda (str)
(and/c string? ((string-length str) . <= . 200)))])
(lambda (str) @{Constructs a string whose ampersand characters are
((string-length str) . <= . 200))))) escaped; the label is also trimmed to <= 200
"Constructs a string whose ampersand characters are" characters.})
"escaped; the label is also trimmed to <= 200"
"characters.")
(gui-utils:format-literal-label (proc-doc
((string?) gui-utils:format-literal-label
(listof any/c) (->d ([str string?])
. ->d* . ()
(lambda (str . rest) #:rest rest (listof any/c)
(and/c string? [_ (and/c string?
(lambda (str) (lambda (str)
((string-length str) . <= . 200))))) ((string-length str) . <= . 200)))])
"Formats a string whose ampersand characters are" @{Formats a string whose ampersand characters are
"escaped; the label is also trimmed to <= 200" escaped; the label is also trimmed to <= 200
"characters.") characters.})
(gui-utils:cancel-on-right? (proc-doc/names
gui-utils:cancel-on-right?
(-> boolean?) (-> boolean?)
() ()
"Returns \\scheme{#t} if cancel should be on the right-hand side (or below)" @{Returns @scheme[#t] if cancel should be on the right-hand side (or below)
"in a dialog and \\scheme{#f} otherwise." in a dialog and @scheme[#f] otherwise.
""
"See also" See also @scheme[gui-utils:ok/cancel-buttons].})
"@flink gui-utils:ok/cancel-buttons %" (proc-doc/names
".") gui-utils:ok/cancel-buttons
(gui-utils:ok/cancel-buttons (->* ((is-a?/c area-container<%>)
(opt->*
((is-a?/c area-container<%>)
((is-a?/c button%) (is-a?/c event%) . -> . any) ((is-a?/c button%) (is-a?/c event%) . -> . any)
((is-a?/c button%) (is-a?/c event%) . -> . any)) ((is-a?/c button%) (is-a?/c event%) . -> . any))
(string? (string?
string?) string?)
((is-a?/c button%) (values (is-a?/c button%)
(is-a?/c button%))) (is-a?/c button%)))
((parent ((parent
confirm-callback confirm-callback
cancel-callback) cancel-callback)
((confirm-label (string-constant ok)) ((confirm-label (string-constant ok))
(cancel-label (string-constant cancel)))) (cancel-label (string-constant cancel))))
"Adds an Ok and a cancel button to a panel, changing the order" @{Adds an Ok and a cancel button to a panel, changing the order
"to suit the platform. Under \\MacOSBoth{} and unix, the confirmation action" 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" is on the right (or bottom) and under Windows, the canceling action is on the
"right (or bottom)." right (or bottom).
"The confirmation action button has the \\scheme|'(border)| style." The confirmation action button has the @scheme['(border)] style.
"The buttons are also sized to be the same width." 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? %"
".")
(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?) (-> string?)
() ()
"Returns a name for the next opened untitled frame. The first" @{Returns a name for the next opened untitled frame. The first
"name is ``Untitled'', the second is ``Untitled 2''," name is ``Untitled'', the second is ``Untitled 2'',
"the third is ``Untitled 3'', and so forth.") the third is ``Untitled 3'', and so forth.})
(gui-utils:cursor-delay (proc-doc/names
gui-utils:cursor-delay
(case-> (case->
(-> real?) (-> real?)
(real? . -> . void?)) (real? . -> . void?))
(() (new-delay)) (() (new-delay))
"This function is {\\em not\\/} a parameter." @{This function is @italic{not} a parameter.
"Instead, the state is just stored in the closure." 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."
"The second case in the case lambda" The first case in the case lambda
"Sets the delay, in seconds, before a watch cursor is shown, when" returns the current delay in seconds before a watch cursor is shown,
"either \\iscmprocedure{gui-utils:local-busy-cursor} or" when either @scheme[gui-utils:local-busy-cursor] or
"\\iscmprocedure{gui-utils:show-busy-cursor} is called.") @scheme[gui-utils:show-busy-cursor] is called.
(gui-utils:show-busy-cursor
(opt-> The second case in the case lambda
((-> any/c)) 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?) (integer?)
any/c) any/c)
((thunk) ((thunk)
((delay (gui-utils:cursor-delay)))) ((delay (gui-utils:cursor-delay))))
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument" @{Evaluates @scheme[(thunk)] with a watch cursor. The argument
"\\var{delay} specifies the amount of time before the watch cursor is" @scheme[delay] specifies the amount of time before the watch cursor is
"opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value" opened. Use @scheme[gui-utils:cursor-delay] to set this value
"to all calls." to all calls.
""
"This function returns the result of \\var{thunk}.") This function returns the result of @scheme[thunk].})
(gui-utils:delay-action (proc-doc/names
gui-utils:delay-action
(real? (real?
(-> void?) (-> void?)
(-> void?) (-> void?)
. -> . . -> .
void?) void?)
(delay-time open close) (delay-time open close)
"Use this function to delay an action for some period of time. It also" @{Use this function to delay an action for some period of time. It also
"supports cancelling the action before the time period elapses. For" supports cancelling the action before the time period elapses. For
"example, if you want to display a watch cursor, but you only want it" 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" to appear after 2 seconds and the action may or may not take more than
"two seconds, use this pattern:" 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.")
(gui-utils:local-busy-cursor @schemeblock[
(opt-> (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<%>) ((is-a?/c window<%>)
(-> any/c)) (-> any/c))
(integer?) (integer?)
any/c) any/c)
((window thunk) ((window thunk)
((delay (gui-utils:cursor-delay)))) ((delay (gui-utils:cursor-delay))))
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If" @{Evaluates @scheme[(thunk)] with a watch cursor in @scheme[window]. If
"\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The" @scheme[window] is @scheme[#f], the watch cursor is turned on globally. The
"argument \\var{delay} specifies the amount of time before the watch" argument @scheme[delay] specifies the amount of time before the watch
"cursor is opened. Use " cursor is opened. Use
"@flink gui-utils:cursor-delay " @scheme[gui-utils:cursor-delay]
"to set this value for all uses of this function." to set this value for all uses of this function.
""
"The result of this function is the result of \\var{thunk}.")
(gui-utils:unsaved-warning The result of this function is the result of @scheme[thunk].})
(opt->
(proc-doc/names
gui-utils:unsaved-warning
(->*
(string? (string?
string?) string?)
(boolean? (boolean?
@ -464,19 +460,19 @@
((can-save-now? #f) ((can-save-now? #f)
(parent #f))) (parent #f)))
"This displays a dialog that warns the user of a unsaved file." @{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}.")
(gui-utils:get-choice The string, @scheme[action], indicates what action is about to
(opt-> take place, without saving. For example, if the application
(string? 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?) string?)
(string? (string?
@ -495,74 +491,70 @@
(checkbox-proc #f) (checkbox-proc #f)
(checkbox-label (string-constant dont-ask-again)))) (checkbox-label (string-constant dont-ask-again))))
"Opens a dialog that presents a binary choice to the user. The user is forced" @{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" 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." 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.")
(gui-utils:get-clicked-clickback-delta The dialog will contain the string @scheme[message] and two buttons,
(opt-> 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?) (boolean?)
(is-a?/c style-delta%)) (is-a?/c style-delta%))
(() (()
((white-on-black? #f))) ((white-on-black? #f)))
"This delta is designed for use with" @{This delta is designed for use with
"@link text set-clickback %" @method[text set-clickback].
". Use it as one of the \\iscmclass{style-delta} argument to" Use it as one of the @scheme[style-delta%] argument to
"@link text set-clickback %" @method[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 %"
".")
(gui-utils:get-clickback-delta If @scheme[white-on-black?] is true, the function returns
(opt-> 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?) (boolean?)
(is-a?/c style-delta%)) (is-a?/c style-delta%))
(() (()
((white-on-black? #f))) ((white-on-black? #f)))
"This delta is designed for use with" @{This delta is designed for use with
"@link text set-clickback %" @method[text% set-clickback].
". Use the result of this function as the style" Use the result of this function as the style
"for the region" for the region
"text where the clickback is set." text where the clickback is set.
""
"If \\var{white-on-black?} is true, the function returns" If @scheme[white-on-black?] is true, the function returns
"a delta suitable for use on a black background." a delta suitable for use on a black background.
""
"See also" See also
"@flink gui-utils:get-clicked-clickback-delta %" @scheme[gui-utils:get-clicked-clickback-delta].}))
".")))

456
collects/framework/preferences.ss
View File

@ -1,4 +1,5 @@
#reader scribble/reader
#lang scheme/gui
#| #|
There are three attributes for each preference: There are three attributes for each preference:
@ -26,77 +27,69 @@ the state transitions / contracts are:
|# |#
(module preferences mzscheme (require scribble/srcdoc)
(require mzlib/file (require/doc scheme/base scribble/manual)
mzlib/etc
mzlib/contract)
(provide exn:struct:unknown-preference) (provide exn:struct:unknown-preference)
(define-struct (exn:unknown-preference exn) ()) (define-struct (exn:unknown-preference exn) ())
;; these two names are for consistency ;; these two names are for consistency
(define exn:make-unknown-preference make-exn:unknown-preference) (define exn:make-unknown-preference make-exn:unknown-preference)
(define exn:struct:unknown-preference struct:exn:unknown-preference) (define exn:struct:unknown-preference struct:exn:unknown-preference)
(define-syntax (provide/contract/docs stx) (define old-preferences-symbol 'plt:framework-prefs)
(syntax-case stx () (define old-preferences (make-hasheq))
[(_ (name contract docs ...) ...) (let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(syntax (provide/contract (name contract) ...))]))
(define old-preferences-symbol 'plt:framework-prefs)
(define old-preferences (make-hash-table))
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
(for-each (for-each
(λ (line) (hash-table-put! old-preferences (car line) (cadr line))) (λ (line) (hash-set! old-preferences (car line) (cadr line)))
old-prefs)) old-prefs))
(define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p))) (define (add-pref-prefix p) (string->symbol (format "plt:framework-pref:~a" p)))
;; preferences : hash-table[sym -o> any] ;; preferences : hash-table[sym -o> any]
;; the current values of the preferences ;; the current values of the preferences
(define preferences (make-hash-table)) (define preferences (make-hasheq))
;; marshalled : hash-table[sym -o> any] ;; marshalled : hash-table[sym -o> any]
;; the values of the preferences, as read in from the disk ;; the values of the preferences, as read in from the disk
;; each symbol will only be mapped in one of the preferences ;; each symbol will only be mapped in one of the preferences
;; hash-table and this hash-table, but not both. ;; hash-table and this hash-table, but not both.
(define marshalled (make-hash-table)) (define marshalled (make-hasheq))
;; marshall-unmarshall : sym -o> un/marshall ;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hash-table)) (define marshall-unmarshall (make-hasheq))
;; callbacks : sym -o> (listof (sym TST -> boolean)) ;; callbacks : sym -o> (listof (sym TST -> boolean))
(define callbacks (make-hash-table)) (define callbacks (make-hasheq))
;; defaults : hash-table[sym -o> default] ;; defaults : hash-table[sym -o> default]
(define defaults (make-hash-table)) (define defaults (make-hasheq))
;; these four functions determine the state of a preference ;; these four functions determine the state of a preference
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref)) (define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
(define (pref-default-set? pref) (hash-table-bound? defaults pref)) (define (pref-default-set? pref) (hash-table-bound? defaults pref))
(define (pref-can-init? pref) (define (pref-can-init? pref)
(and (not snapshot-grabbed?) (and (not snapshot-grabbed?)
(not (hash-table-bound? preferences pref)))) (not (hash-table-bound? preferences pref))))
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any)) ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
(define-struct un/marshall (marshall unmarshall)) (define-struct un/marshall (marshall unmarshall))
;; type pref = (make-pref any) ;; type pref = (make-pref any)
(define-struct pref (value)) (define-struct pref (value))
;; type default = (make-default any (any -> bool)) ;; type default = (make-default any (any -> bool))
(define-struct default (value checker)) (define-struct default (value checker))
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void))) ;; 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?. ;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
(define-struct pref-callback (cb)) (define-struct pref-callback (cb))
;; get : symbol -> any ;; get : symbol -> any
;; return the current value of the preference `p' ;; return the current value of the preference `p'
;; exported ;; exported
(define (preferences:get p) (define (preferences:get p)
(cond (cond
[(pref-default-set? p) [(pref-default-set? p)
@ -104,51 +97,51 @@ the state transitions / contracts are:
(when (hash-table-bound? marshalled p) (when (hash-table-bound? marshalled p)
;; if `preferences' is already bound, that means the unmarshalled value isn't useful. ;; if `preferences' is already bound, that means the unmarshalled value isn't useful.
(unless (hash-table-bound? preferences p) (unless (hash-table-bound? preferences p)
(hash-table-put! preferences p (unmarshall-pref p (hash-table-get marshalled p)))) (hash-set! preferences p (unmarshall-pref p (hash-ref marshalled p))))
(hash-table-remove! marshalled p)) (hash-remove! marshalled p))
;; if there is no value in the preferences table, but there is one ;; if there is no value in the preferences table, but there is one
;; in the old version preferences file, take that: ;; in the old version preferences file, take that:
(unless (hash-table-bound? preferences p) (unless (hash-table-bound? preferences p)
(when (hash-table-bound? old-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) ;; 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) (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 ;; if it still isn't set, take the default value
(unless (hash-table-bound? preferences p) (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)) [(not (pref-default-set? p))
(raise-unknown-preference-error (raise-unknown-preference-error
'preferences:get 'preferences:get
"tried to get a preference but no default set for ~e" "tried to get a preference but no default set for ~e"
p)])) p)]))
;; set : symbol any -> void ;; set : symbol any -> void
;; updates the preference ;; updates the preference
;; exported ;; exported
(define (preferences:set p value) (multi-set (list p) (list value))) (define (preferences:set p value) (multi-set (list p) (list value)))
;; set : symbol any -> void ;; set : symbol any -> void
;; updates the preference ;; updates the preference
;; exported ;; exported
(define (multi-set ps values) (define (multi-set ps values)
(for-each (for-each
(λ (p value) (λ (p value)
(cond (cond
[(pref-default-set? p) [(pref-default-set? p)
(let ([default (hash-table-get defaults p)]) (let ([default (hash-ref defaults p)])
(unless ((default-checker default) value) (unless ((default-checker default) value)
(error 'preferences:set (error 'preferences:set
"tried to set preference ~e to ~e but it does not meet test from preferences:set-default" "tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
p value)) p value))
(check-callbacks p value) (check-callbacks p value)
(hash-table-put! preferences p value) (hash-set! preferences p value)
(void))] (void))]
[(not (pref-default-set? p)) [(not (pref-default-set? p))
(raise-unknown-preference-error (raise-unknown-preference-error
@ -164,41 +157,41 @@ the state transitions / contracts are:
(void)) (void))
(define preferences:low-level-put-preferences (make-parameter put-preferences)) (define preferences:low-level-put-preferences (make-parameter put-preferences))
(define (raise-unknown-preference-error sym fmt . args) (define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference (raise (exn:make-unknown-preference
(string-append (format "~a: " sym) (apply format fmt args)) (string-append (format "~a: " sym) (apply format fmt args))
(current-continuation-marks)))) (current-continuation-marks))))
;; unmarshall-pref : symbol marshalled -> any ;; unmarshall-pref : symbol marshalled -> any
;; unmarshalls a preference read from the disk ;; unmarshalls a preference read from the disk
(define (unmarshall-pref p data) (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 [result (if un/marshall
((un/marshall-unmarshall un/marshall) data) ((un/marshall-unmarshall un/marshall) data)
data)] data)]
[default (hash-table-get defaults p)]) [default (hash-ref defaults p)])
(if ((default-checker default) result) (if ((default-checker default) result)
result result
(default-value default)))) (default-value default))))
;; add-callback : sym (-> void) -> void ;; add-callback : sym (-> void) -> void
(define preferences:add-callback (define preferences:add-callback
(opt-lambda (p callback [weak? #f]) (lambda (p callback [weak? #f])
(let ([new-cb (make-pref-callback (if weak? (let ([new-cb (make-pref-callback (if weak?
(make-weak-box callback) (make-weak-box callback)
callback))]) callback))])
(hash-table-put! callbacks (hash-set! callbacks
p p
(append (append
(hash-table-get callbacks p (λ () null)) (hash-ref callbacks p (λ () null))
(list new-cb))) (list new-cb)))
(λ () (λ ()
(hash-table-put! (hash-set!
callbacks callbacks
p p
(let loop ([callbacks (hash-table-get callbacks p (λ () null))]) (let loop ([callbacks (hash-ref callbacks p (λ () null))])
(cond (cond
[(null? callbacks) null] [(null? callbacks) null]
[else [else
@ -209,10 +202,10 @@ the state transitions / contracts are:
[else [else
(cons (car callbacks) (loop (cdr callbacks)))]))]))))))) (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
;; check-callbacks : sym val -> void ;; check-callbacks : sym val -> void
(define (check-callbacks p value) (define (check-callbacks p value)
(let ([new-callbacks (let ([new-callbacks
(let loop ([callbacks (hash-table-get callbacks p (λ () null))]) (let loop ([callbacks (hash-ref callbacks p (λ () null))])
(cond (cond
[(null? callbacks) null] [(null? callbacks) null]
[else [else
@ -230,15 +223,15 @@ the state transitions / contracts are:
(cb p value) (cb p value)
(cons callback (loop (cdr callbacks)))]))]))]) (cons callback (loop (cdr callbacks)))]))]))])
(if (null? new-callbacks) (if (null? new-callbacks)
(hash-table-remove! callbacks p) (hash-remove! callbacks p)
(hash-table-put! callbacks p new-callbacks)))) (hash-set! callbacks p new-callbacks))))
(define (preferences:set-un/marshall p marshall unmarshall) (define (preferences:set-un/marshall p marshall unmarshall)
(cond (cond
[(and (pref-default-set? p) [(and (pref-default-set? p)
(not (pref-un/marshall-set? p)) (not (pref-un/marshall-set? p))
(pref-can-init? 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)) [(not (pref-default-set? p))
(error 'preferences:set-un/marshall (error 'preferences:set-un/marshall
"must call set-default for ~s before calling set-un/marshall for ~s" "must call set-default for ~s before calling set-un/marshall for ~s"
@ -250,18 +243,18 @@ the state transitions / contracts are:
[(not (pref-can-init? p)) [(not (pref-can-init? p))
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])) (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
(define (hash-table-bound? ht s) (define (hash-table-bound? ht s)
(let/ec k (let/ec k
(hash-table-get ht s (λ () (k #f))) (hash-ref ht s (λ () (k #f)))
#t)) #t))
(define (preferences:restore-defaults) (define (preferences:restore-defaults)
(hash-table-for-each (hash-for-each
defaults defaults
(λ (p def) (preferences:set p (default-value def))))) (λ (p def) (preferences:set p (default-value def)))))
;; set-default : (sym TST (TST -> boolean) -> void ;; set-default : (sym TST (TST -> boolean) -> void
(define (preferences:set-default p default-value checker) (define (preferences:set-default p default-value checker)
(cond (cond
[(and (not (pref-default-set? p)) [(and (not (pref-default-set? p))
(pref-can-init? p)) (pref-can-init? p))
@ -269,12 +262,12 @@ the state transitions / contracts are:
(unless default-okay? (unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n" (error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
p checker default-okay? default-value)) 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/ec k
(let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))]) (let ([m (get-preference (add-pref-prefix p) (λ () (k (void))))])
;; if there is no preference saved, we just don't do anything. ;; if there is no preference saved, we just don't do anything.
;; `get' notices this case. ;; `get' notices this case.
(hash-table-put! marshalled p m))))] (hash-set! marshalled p m))))]
[(not (pref-can-init? p)) [(not (pref-can-init? p))
(error 'preferences:set-default (error 'preferences:set-default
"tried to call set-default for preference ~e but it cannot be configured any more" "tried to call set-default for preference ~e but it cannot be configured any more"
@ -286,101 +279,102 @@ the state transitions / contracts are:
(error 'preferences:set-default (error 'preferences:set-default
"can no longer set the default for ~e" p)])) "can no longer set the default for ~e" p)]))
;; marshall-pref : symbol any -> (list symbol printable) ;; marshall-pref : symbol any -> (list symbol printable)
(define (marshall-pref p value) (define (marshall-pref p value)
(let/ec k (let/ec k
(let* ([marshaller (let* ([marshaller
(un/marshall-marshall (un/marshall-marshall
(hash-table-get marshall-unmarshall p (λ () (k value))))]) (hash-ref marshall-unmarshall p (λ () (k value))))])
(marshaller value)))) (marshaller value))))
(define-struct preferences:snapshot (x)) (define-struct preferences:snapshot (x))
(define snapshot-grabbed? #f) (define snapshot-grabbed? #f)
(define (preferences:get-prefs-snapshot) (define (preferences:get-prefs-snapshot)
(set! snapshot-grabbed? #t) (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) (define (preferences:restore-prefs-snapshot snapshot)
(multi-set (map car (preferences:snapshot-x snapshot)) (multi-set (map car (preferences:snapshot-x snapshot))
(map cdr (preferences:snapshot-x snapshot))) (map cdr (preferences:snapshot-x snapshot)))
(void)) (void))
(provide/contract/docs (provide/doc
(preferences:snapshot? (proc-doc/names
preferences:snapshot?
(-> any/c boolean?) (-> any/c boolean?)
(arg) (arg)
"Determines if its argument is a preferences snapshot." @{Determines if its argument is a preferences snapshot.
""
"See also " See also
"@flink preferences:get-prefs-snapshot" @scheme[preferences:get-prefs-snapshot] and
" and " @scheme[preferences:restore-prefs-snapshot].})
"@flink preferences:restore-prefs-snapshot %" (proc-doc/names
".") preferences:restore-prefs-snapshot
(preferences:restore-prefs-snapshot
(-> preferences:snapshot? void?) (-> preferences:snapshot? void?)
(snapshot) (snapshot)
"Restores the preferences saved in \\var{snapshot}." @{Restores the preferences saved in @scheme[snapshot].
""
"See also "
"@flink preferences:get-prefs-snapshot %"
".")
(preferences:get-prefs-snapshot See also @scheme[preferences:get-prefs-snapshot].})
(proc-doc/names
preferences:get-prefs-snapshot
(-> preferences:snapshot?) (-> preferences:snapshot?)
() ()
"Caches all of the current values of the preferences and returns them." @{Caches all of the current values of the preferences and returns them.
""
"See also "
"@flink preferences:restore-prefs-snapshot %"
".")
(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?) (string? continuation-mark-set? . -> . exn:unknown-preference?)
(message continuation-marks) (message continuation-marks)
"Creates an unknown preference exception.") @{Creates an unknown preference exception.})
(exn:unknown-preference? (proc-doc/names
exn:unknown-preference?
(any/c . -> . boolean?) (any/c . -> . boolean?)
(exn) (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)) (parameter/c (-> (listof symbol?) (listof any/c) any))
() put-preference
"This is a parameter (see " @{This parameter's value
"\\Mzhyperref{parameters}{mz:parameters} for information about parameters)" is called when to save preference the preferences. Its interface should
"which is called when a preference is saved. Its interface should " be just like mzlib's @scheme[put-preference].})
"be just like mzlib's \\scheme|put-preference|.")
(preferences:get (proc-doc/names
preferences:get
(symbol? . -> . any/c) (symbol? . -> . any/c)
(symbol) (symbol)
"See also" @{See also @scheme[preferences:set-default].
"@flink preferences:set-default %"
"." @scheme[preferences:get] returns the value for the preference
"" @scheme[symbol]. It raises
"\\rawscm{preferences:get} returns the value for the preference" @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
"\\var{symbol}. It raises" @scheme[exn:unknown-preference]
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}" if the preference's default has not been set.})
"if the preference's default has not been set.") (proc-doc/names
(preferences:set preferences:set
(symbol? any/c . -> . void?) (symbol? any/c . -> . void?)
(symbol value) (symbol value)
"See also" @{See also @scheme[preferences:set-default].
"@flink preferences:set-default %"
"." @scheme[preferences:set-preference] sets the preference
"" @scheme[symbol] to @scheme[value]. This should be called when the
"\\rawscm{preferences:set-preference} sets the preference" users requests a change to a 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.
""
"This function immediately writes the preference value to disk." It raises
"" @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
"It raises" if the preference's default has not been set.})
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}" (proc-doc/names
"if the preference's default has not been set.") preferences:add-callback
(preferences:add-callback (->* (symbol?
(opt-> (symbol?
;; important that this arg only has a flat contract ;; important that this arg only has a flat contract
;; so that no wrapper is created, so that ;; so that no wrapper is created, so that
@ -390,79 +384,81 @@ the state transitions / contracts are:
(-> void?)) (-> void?))
((p f) ((p f)
((weak? #f))) ((weak? #f)))
"This function adds a callback which is called with a symbol naming a" @{This function adds a callback which is called with a symbol naming a
"preference and it's value, when the preference changes." preference and it's value, when the preference changes.
"\\rawscm{preferences:add-callback} returns a thunk, which when" @scheme[preferences:add-callback] returns a thunk, which when
"invoked, removes the callback from this preference." invoked, removes the callback from this preference.
""
"If \\var{weak?} is true, the preferences system will only hold on to" If @scheme[weak?] is true, the preferences system will only hold on to
"the callback weakly." the callback weakly.
""
"The callbacks will be called in the order in which they were added." The callbacks will be called in the order in which they were added.
""
"If you are adding a callback for a preference that requires" If you are adding a callback for a preference that requires
"marshalling and unmarshalling, you must set the marshalling and" marshalling and unmarshalling, you must set the marshalling and
"unmarshalling functions by calling" unmarshalling functions by calling
"\\iscmprocedure{preferences:set-un/marshall} before adding a callback." @scheme[preferences:set-un/marshall] before adding a callback.
""
"This function raises" This function raises
"\\scmindex{exn:unknown-preference}\\rawscm{exn:unknown-preference}" @index['("exn:unknown-preference")]{@scheme[exn:unknown-preference]}
"if the preference has not been set.") @scheme[exn:unknown-preference]
(preferences:set-default if the preference has not been set.})
(proc-doc/names
preferences:set-default
(symbol? any/c (any/c . -> . any) . -> . void?) (symbol? any/c (any/c . -> . any) . -> . void?)
(symbol value test) (symbol value test)
"This function must be called every time your application starts up, before any call to" @{This function must be called every time your application starts up, before any call to
"@flink preferences:get %" @scheme[preferences:get] or
", " @scheme[preferences:set]
"@flink preferences:set" (for any given preference).
"(for any given preference)."
"" If you use
"If you use" @scheme[preferences:set-un/marshall],
"@flink preferences:set-un/marshall %" you must call this function before calling it.
", you must call this function before calling it."
"" This sets the default value of the preference @scheme[symbol] to
"This sets the default value of the preference \\var{symbol} to" @scheme[value]. If the user has chosen a different setting,
"\\var{value}. If the user has chosen a different setting," the user's setting
"the user's setting" will take precedence over the default value.
"will take precedence over the default value."
"" The last argument, @scheme[test] is used as a safeguard. That function is
"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
"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
"preference. If \\var{test} returns \\rawscm{\\#t}, then the preference is" treated as valid. If @scheme[test] returns @scheme[#f] then the default is
"treated as valid. If \\var{test} returns \\rawscm{\\#f} then the default is" used.})
"used.") (proc-doc/names
(preferences:set-un/marshall preferences:set-un/marshall
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?) (symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
(symbol marshall unmarshall) (symbol marshall unmarshall)
"\\rawscm{preference:set-un/marshall} is used to specify marshalling and" @{@scheme[preference:set-un/marshall] is used to specify marshalling and
"unmarshalling functions for the preference" unmarshalling functions for the preference
"\\var{symbol}. \\var{marshall} will be called when the users saves their" @scheme[symbol]. @scheme[marshall] will be called when the users saves their
"preferences to turn the preference value for \\var{symbol} into a" preferences to turn the preference value for @scheme[symbol] into a
"printable value. \\var{unmarshall} will be called when the user's" printable value. @scheme[unmarshall] will be called when the user's
"preferences are read from the file to transform the printable value" preferences are read from the file to transform the printable value
"into it's internal representation. If \\rawscm{preference:set-un/marshall}" into it's internal representation. If @scheme[preference:set-un/marshall]
"is never called for a particular preference, the values of that" is never called for a particular preference, the values of that
"preference are assumed to be printable." 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 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?) (-> void?)
() ()
"\\rawscm{(preferences:restore-defaults)} restores the users's configuration to the" @{@scheme[(preferences:restore-defaults)]
"default preferences."))) restores the users's configuration to the
default preferences.}))

5
collects/framework/test.ss
View File

@ -4,11 +4,6 @@
(require scribble/srcdoc) (require scribble/srcdoc)
(require/doc scheme/base scribble/manual) (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) (define (test:top-level-focus-window-has? pred)
(let ([tlw (get-top-level-focus-window)]) (let ([tlw (get-top-level-focus-window)])
(and tlw (and tlw

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} @title{@bold{Framework}: PLT GUI Application Framework}
The framework provides these libraries:
@itemize{ @itemize{
@item{Mode}
@item{``Cannot parse docs for handler:open-file''}
@item{Check indexing in preferences:get}
}
@itemize{
@item{@bold{Entire Framework} @item{@bold{Entire Framework}
@itemize{ @itemize{
@ -74,8 +78,7 @@ The precise set of exported names is:
@scheme[preferences:restore-defaults]. @scheme[preferences:restore-defaults].
}} }}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @bold{Thanks}
@section{Thanks}
Thanks to Shriram Krishnamurthi, Cormac Flanagan, Matthias Thanks to Shriram Krishnamurthi, Cormac Flanagan, Matthias
Felleisen, Ian Barland, Gann Bierner, Richard Cobbe, Dan 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 Ernst, Kennis Koldewyn, Bruce Duba, and many others for
their feedback and help. their feedback and help.
@include-section["application.scrbl"]
@include-section["framework-application.scrbl"] @include-section["autosave.scrbl"]
@include-section["framework-autosave.scrbl"] @include-section["canvas.scrbl"]
@include-section["framework-canvas.scrbl"] @include-section["color-model.scrbl"]
@include-section["framework-color-model.scrbl"] @include-section["color-prefs.scrbl"]
@include-section["framework-color-prefs.scrbl"] @include-section["color.scrbl"]
@include-section["framework-color.scrbl"] @include-section["comment-box.scrbl"]
@include-section["framework-comment-box.scrbl"] @include-section["editor.scrbl"]
@include-section["framework-editor.scrbl"] @include-section["exit.scrbl"]
@include-section["framework-exit.scrbl"] @include-section["finder.scrbl"]
@include-section["framework-finder.scrbl"] @include-section["frame.scrbl"]
@include-section["framework-frame.scrbl"] @include-section["group.scrbl"]
@include-section["framework-group.scrbl"] @include-section["gui-utils.scrbl"]
@include-section["framework-handler.scrbl"] @include-section["handler.scrbl"]
@include-section["framework-icon.scrbl"] @include-section["icon.scrbl"]
@include-section["framework-keymap.scrbl"] @include-section["keymap.scrbl"]
@;include-section["framework-main.scrbl"] @include-section["menu.scrbl"]
@include-section["framework-menu.scrbl"] @include-section["mode.scrbl"]
@;include-section["framework-mode.scrbl"] @include-section["number-snip.scrbl"]
@include-section["framework-number-snip.scrbl"] @include-section["panel.scrbl"]
@include-section["framework-panel.scrbl"] @include-section["pasteboard.scrbl"]
@include-section["framework-pasteboard.scrbl"] @include-section["path-utils.scrbl"]
@include-section["framework-path-utils.scrbl"] @include-section["preferences.scrbl"]
@include-section["framework-preferences.scrbl"] @include-section["preferences-text.scrbl"]
@include-section["framework-scheme.scrbl"] @include-section["scheme.scrbl"]
@include-section["framework-text.scrbl"] @include-section["text.scrbl"]
@include-section["framework-test.scrbl"] @include-section["test.scrbl"]
@include-section["framework-version.scrbl"] @include-section["version.scrbl"]
@index-section[] @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