added docs for the gui-utils and the textual preferences to the framework
svn: r9503
This commit is contained in:
Robby Findler
parent
aceb620344
commit
d07eff8bce
|
|
@ -1,18 +1,12 @@
|
|||
#reader scribble/reader
|
||||
#lang scheme/gui
|
||||
|
||||
(module gui-utils mzscheme
|
||||
(require mzlib/class
|
||||
mred
|
||||
mzlib/etc
|
||||
mzlib/contract
|
||||
string-constants)
|
||||
(require string-constants)
|
||||
|
||||
(define-syntax (provide/contract/docs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
(require scribble/srcdoc)
|
||||
(require/doc scheme/base scribble/manual)
|
||||
|
||||
|
||||
(define (trim-string str size)
|
||||
(define (trim-string str size)
|
||||
(let ([str-size (string-length str)])
|
||||
(cond
|
||||
[(<= str-size size)
|
||||
|
|
@ -37,35 +31,35 @@
|
|||
str-size))]))])))
|
||||
|
||||
|
||||
(define maximum-string-label-length 200)
|
||||
(define maximum-string-label-length 200)
|
||||
|
||||
;; format-literal-label: string any* -> string
|
||||
(define (format-literal-label format-str . args)
|
||||
;; format-literal-label: string any* -> string
|
||||
(define (format-literal-label format-str . args)
|
||||
(quote-literal-label (apply format format-str args)))
|
||||
|
||||
;; quote-literal-label: string -> string
|
||||
(define (quote-literal-label a-str)
|
||||
;; quote-literal-label: string -> string
|
||||
(define (quote-literal-label a-str)
|
||||
(trim-string (regexp-replace* #rx"(&)" a-str "\\1\\1")
|
||||
maximum-string-label-length))
|
||||
|
||||
|
||||
|
||||
;; selected-text-color : color
|
||||
(define selected-text-color (send the-color-database find-color "black"))
|
||||
;; selected-text-color : color
|
||||
(define selected-text-color (send the-color-database find-color "black"))
|
||||
|
||||
;; unselected-text-color : color
|
||||
(define unselected-text-color (case (system-type)
|
||||
;; unselected-text-color : color
|
||||
(define unselected-text-color (case (system-type)
|
||||
[(macosx) (make-object color% 75 75 75)]
|
||||
[else (send the-color-database find-color "black")]))
|
||||
|
||||
;; selected-brush : brush
|
||||
(define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
|
||||
;; selected-brush : brush
|
||||
(define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
|
||||
|
||||
;; unselected-brush : brush
|
||||
(define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
|
||||
;; unselected-brush : brush
|
||||
(define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
|
||||
|
||||
;; button-down/over-brush : brush
|
||||
(define button-down/over-brush
|
||||
;; button-down/over-brush : brush
|
||||
(define button-down/over-brush
|
||||
(case (system-type)
|
||||
[(macosx) (send the-brush-list find-or-create-brush
|
||||
"light blue"
|
||||
|
|
@ -76,50 +70,50 @@
|
|||
'solid)]))
|
||||
|
||||
|
||||
;; name-box-pen : pen
|
||||
;; this pen draws the lines around each individual item
|
||||
(define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
;; name-box-pen : pen
|
||||
;; this pen draws the lines around each individual item
|
||||
(define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
|
||||
;; background-brush : brush
|
||||
;; this brush is set when drawing the background for the control
|
||||
(define background-brush
|
||||
;; background-brush : brush
|
||||
;; this brush is set when drawing the background for the control
|
||||
(define background-brush
|
||||
(case (system-type)
|
||||
[(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)]
|
||||
[else (send the-brush-list find-or-create-brush "white" 'solid)]))
|
||||
|
||||
;; background-pen : pen
|
||||
;; 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))
|
||||
;; background-pen : pen
|
||||
;; 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))
|
||||
|
||||
;; label-font : font
|
||||
(define label-font (send the-font-list find-or-create-font
|
||||
;; label-font : font
|
||||
(define label-font (send the-font-list find-or-create-font
|
||||
(if (eq? (system-type) 'windows) 10 12)
|
||||
'system 'normal
|
||||
(if (eq? (system-type) 'macosx) 'bold 'normal)
|
||||
#f))
|
||||
|
||||
;; name-gap : number
|
||||
;; the space between each name
|
||||
(define name-gap 4)
|
||||
;; name-gap : number
|
||||
;; the space between each name
|
||||
(define name-gap 4)
|
||||
|
||||
;; hang-over : number
|
||||
;; the amount of space a single entry "slants" over
|
||||
(define hang-over 8)
|
||||
;; hang-over : number
|
||||
;; the amount of space a single entry "slants" over
|
||||
(define hang-over 8)
|
||||
|
||||
;; top-space : number
|
||||
;; the gap at the top of the canvas, above all the choices
|
||||
(define top-space 4)
|
||||
;; top-space : number
|
||||
;; the gap at the top of the canvas, above all the choices
|
||||
(define top-space 4)
|
||||
|
||||
;; bottom-space : number
|
||||
;; the extra space below the words
|
||||
(define bottom-space 2)
|
||||
;; bottom-space : number
|
||||
;; the extra space below the words
|
||||
(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
|
||||
(opt-lambda (parent
|
||||
(define ok/cancel-buttons
|
||||
(lambda (parent
|
||||
confirm-callback
|
||||
cancel-callback
|
||||
[confirm-str (string-constant ok)]
|
||||
|
|
@ -150,27 +144,31 @@
|
|||
(values b2 b1)))))))
|
||||
|
||||
|
||||
(define clickback-delta (make-object style-delta% 'change-underline #t))
|
||||
(define white-on-black-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))
|
||||
(let ()
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(send white-on-black-clickback-delta set-delta-foreground "deepskyblue")
|
||||
(define get-clickback-delta
|
||||
(opt-lambda ([white-on-black? #f])
|
||||
(void))
|
||||
(define get-clickback-delta
|
||||
(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%))
|
||||
(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")
|
||||
(define get-clicked-clickback-delta
|
||||
(opt-lambda ([white-on-black? #f])
|
||||
(void))
|
||||
(define get-clicked-clickback-delta
|
||||
(lambda ([white-on-black? #f])
|
||||
(if white-on-black?
|
||||
white-on-black-clicked-clickback-delta
|
||||
clicked-clickback-delta)))
|
||||
|
||||
(define next-untitled-name
|
||||
(define next-untitled-name
|
||||
(let ([n 1])
|
||||
(λ ()
|
||||
(begin0
|
||||
|
|
@ -179,17 +177,17 @@
|
|||
[else (format (string-constant untitled-n) n)])
|
||||
(set! n (+ n 1))))))
|
||||
|
||||
(define cursor-delay
|
||||
(define cursor-delay
|
||||
(let ([x 0.25])
|
||||
(case-lambda
|
||||
[() x]
|
||||
[(v) (set! x v) x])))
|
||||
|
||||
(define show-busy-cursor
|
||||
(opt-lambda (thunk [delay (cursor-delay)])
|
||||
(define show-busy-cursor
|
||||
(lambda (thunk [delay (cursor-delay)])
|
||||
(local-busy-cursor #f thunk delay)))
|
||||
|
||||
(define delay-action
|
||||
(define delay-action
|
||||
(λ (delay-time open close)
|
||||
(let ([semaphore (make-semaphore 1)]
|
||||
[open? #f]
|
||||
|
|
@ -209,7 +207,7 @@
|
|||
(close))
|
||||
(semaphore-post semaphore)))))
|
||||
|
||||
(define local-busy-cursor
|
||||
(define local-busy-cursor
|
||||
(let ([watch (make-object cursor% 'watch)])
|
||||
(case-lambda
|
||||
[(win thunk) (local-busy-cursor win thunk (cursor-delay))]
|
||||
|
|
@ -233,8 +231,8 @@
|
|||
(λ () (thunk))
|
||||
(λ () (cursor-off))))])))
|
||||
|
||||
(define unsaved-warning
|
||||
(opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
|
||||
(define unsaved-warning
|
||||
(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)
|
||||
|
|
@ -251,8 +249,8 @@
|
|||
[(2) 'cancel]
|
||||
[(3) 'continue]))))
|
||||
|
||||
(define get-choice
|
||||
(opt-lambda (message
|
||||
(define get-choice
|
||||
(lambda (message
|
||||
true-choice
|
||||
false-choice
|
||||
(title (string-constant warning))
|
||||
|
|
@ -277,182 +275,180 @@
|
|||
(return (message-box/custom title message true-choice false-choice #f
|
||||
parent style default-result))))))
|
||||
|
||||
;; manual renaming
|
||||
(define gui-utils:trim-string trim-string)
|
||||
(define gui-utils:quote-literal-label quote-literal-label)
|
||||
(define gui-utils:format-literal-label format-literal-label)
|
||||
(define gui-utils:next-untitled-name next-untitled-name)
|
||||
(define gui-utils:show-busy-cursor show-busy-cursor)
|
||||
(define gui-utils:delay-action delay-action)
|
||||
(define gui-utils:local-busy-cursor local-busy-cursor)
|
||||
(define gui-utils:unsaved-warning unsaved-warning)
|
||||
(define gui-utils:get-choice get-choice)
|
||||
(define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta)
|
||||
(define gui-utils:ok/cancel-buttons ok/cancel-buttons)
|
||||
(define gui-utils:cancel-on-right? cancel-on-right?)
|
||||
(define gui-utils:cursor-delay cursor-delay)
|
||||
;; manual renaming
|
||||
(define gui-utils:trim-string trim-string)
|
||||
(define gui-utils:quote-literal-label quote-literal-label)
|
||||
(define gui-utils:format-literal-label format-literal-label)
|
||||
(define gui-utils:next-untitled-name next-untitled-name)
|
||||
(define gui-utils:show-busy-cursor show-busy-cursor)
|
||||
(define gui-utils:delay-action delay-action)
|
||||
(define gui-utils:local-busy-cursor local-busy-cursor)
|
||||
(define gui-utils:unsaved-warning unsaved-warning)
|
||||
(define gui-utils:get-choice get-choice)
|
||||
(define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta)
|
||||
(define gui-utils:ok/cancel-buttons ok/cancel-buttons)
|
||||
(define gui-utils:cancel-on-right? cancel-on-right?)
|
||||
(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].}))
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
|
||||
#reader scribble/reader
|
||||
#lang scheme/gui
|
||||
#|
|
||||
|
||||
There are three attributes for each preference:
|
||||
|
|
@ -26,77 +27,69 @@ 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)
|
||||
(provide exn:struct:unknown-preference)
|
||||
|
||||
(define-struct (exn:unknown-preference exn) ())
|
||||
(define-struct (exn:unknown-preference exn) ())
|
||||
|
||||
;; these two names are for consistency
|
||||
(define exn:make-unknown-preference make-exn:unknown-preference)
|
||||
(define exn:struct:unknown-preference struct:exn:unknown-preference)
|
||||
;; these two names are for consistency
|
||||
(define exn:make-unknown-preference make-exn:unknown-preference)
|
||||
(define exn:struct:unknown-preference struct:exn:unknown-preference)
|
||||
|
||||
(define-syntax (provide/contract/docs stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
|
||||
(define old-preferences-symbol 'plt:framework-prefs)
|
||||
(define old-preferences (make-hash-table))
|
||||
(let ([old-prefs (get-preference old-preferences-symbol (λ () '()))])
|
||||
(define old-preferences-symbol 'plt:framework-prefs)
|
||||
(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)))
|
||||
(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))
|
||||
;; preferences : hash-table[sym -o> any]
|
||||
;; the current values of the preferences
|
||||
(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))
|
||||
;; 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-hasheq))
|
||||
|
||||
;; marshall-unmarshall : sym -o> un/marshall
|
||||
(define marshall-unmarshall (make-hash-table))
|
||||
;; marshall-unmarshall : sym -o> un/marshall
|
||||
(define marshall-unmarshall (make-hasheq))
|
||||
|
||||
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
||||
(define callbacks (make-hash-table))
|
||||
;; callbacks : sym -o> (listof (sym TST -> boolean))
|
||||
(define callbacks (make-hasheq))
|
||||
|
||||
;; defaults : hash-table[sym -o> default]
|
||||
(define defaults (make-hash-table))
|
||||
;; defaults : hash-table[sym -o> default]
|
||||
(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))
|
||||
(define (pref-default-set? pref) (hash-table-bound? defaults pref))
|
||||
(define (pref-can-init? pref)
|
||||
;; these four functions determine the state of a preference
|
||||
(define (pref-un/marshall-set? pref) (hash-table-bound? marshall-unmarshall pref))
|
||||
(define (pref-default-set? pref) (hash-table-bound? defaults pref))
|
||||
(define (pref-can-init? pref)
|
||||
(and (not snapshot-grabbed?)
|
||||
(not (hash-table-bound? preferences pref))))
|
||||
|
||||
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
|
||||
(define-struct un/marshall (marshall unmarshall))
|
||||
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
|
||||
(define-struct un/marshall (marshall unmarshall))
|
||||
|
||||
;; type pref = (make-pref any)
|
||||
(define-struct pref (value))
|
||||
;; type pref = (make-pref any)
|
||||
(define-struct pref (value))
|
||||
|
||||
;; type default = (make-default any (any -> bool))
|
||||
(define-struct default (value checker))
|
||||
;; type default = (make-default any (any -> bool))
|
||||
(define-struct default (value checker))
|
||||
|
||||
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
|
||||
;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
|
||||
(define-struct pref-callback (cb))
|
||||
;; pref-callback : (make-pref-callback (union (weak-box (sym tst -> void)) (sym tst -> void)))
|
||||
;; this is used as a wrapped to deal with the problem that different procedures might be eq?.
|
||||
(define-struct pref-callback (cb))
|
||||
|
||||
;; get : symbol -> any
|
||||
;; return the current value of the preference `p'
|
||||
;; exported
|
||||
(define (preferences:get p)
|
||||
;; get : symbol -> any
|
||||
;; return the current value of the preference `p'
|
||||
;; exported
|
||||
(define (preferences:get p)
|
||||
(cond
|
||||
[(pref-default-set? p)
|
||||
|
||||
|
|
@ -104,51 +97,51 @@ 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
|
||||
"tried to get a preference but no default set for ~e"
|
||||
p)]))
|
||||
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
(define (preferences:set p value) (multi-set (list p) (list value)))
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
(define (preferences:set p value) (multi-set (list p) (list value)))
|
||||
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
;; set : symbol any -> void
|
||||
;; updates the preference
|
||||
;; exported
|
||||
|
||||
(define (multi-set ps values)
|
||||
(define (multi-set ps values)
|
||||
(for-each
|
||||
(λ (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
|
||||
|
|
@ -164,41 +157,41 @@ the state transitions / contracts are:
|
|||
|
||||
(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
|
||||
(string-append (format "~a: " sym) (apply format fmt args))
|
||||
(current-continuation-marks))))
|
||||
|
||||
;; unmarshall-pref : symbol marshalled -> any
|
||||
;; unmarshalls a preference read from the disk
|
||||
(define (unmarshall-pref p data)
|
||||
(let* ([un/marshall (hash-table-get marshall-unmarshall p #f)]
|
||||
;; unmarshall-pref : symbol marshalled -> any
|
||||
;; unmarshalls a preference read from the disk
|
||||
(define (unmarshall-pref p data)
|
||||
(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])
|
||||
;; add-callback : sym (-> void) -> void
|
||||
(define preferences:add-callback
|
||||
(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
|
||||
|
|
@ -209,10 +202,10 @@ the state transitions / contracts are:
|
|||
[else
|
||||
(cons (car callbacks) (loop (cdr callbacks)))]))])))))))
|
||||
|
||||
;; check-callbacks : sym val -> void
|
||||
(define (check-callbacks p value)
|
||||
;; 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)
|
||||
(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"
|
||||
|
|
@ -250,18 +243,18 @@ the state transitions / contracts are:
|
|||
[(not (pref-can-init? p))
|
||||
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
|
||||
|
||||
(define (hash-table-bound? ht s)
|
||||
(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
|
||||
(define (preferences:restore-defaults)
|
||||
(hash-for-each
|
||||
defaults
|
||||
(λ (p def) (preferences:set p (default-value def)))))
|
||||
|
||||
;; set-default : (sym TST (TST -> boolean) -> void
|
||||
(define (preferences:set-default p default-value checker)
|
||||
;; set-default : (sym TST (TST -> boolean) -> void
|
||||
(define (preferences:set-default p default-value checker)
|
||||
(cond
|
||||
[(and (not (pref-default-set? p))
|
||||
(pref-can-init? p))
|
||||
|
|
@ -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"
|
||||
|
|
@ -286,101 +279,102 @@ the state transitions / contracts are:
|
|||
(error 'preferences:set-default
|
||||
"can no longer set the default for ~e" p)]))
|
||||
|
||||
;; marshall-pref : symbol any -> (list symbol printable)
|
||||
(define (marshall-pref p value)
|
||||
;; marshall-pref : symbol any -> (list symbol printable)
|
||||
(define (marshall-pref p value)
|
||||
(let/ec k
|
||||
(let* ([marshaller
|
||||
(un/marshall-marshall
|
||||
(hash-table-get marshall-unmarshall p (λ () (k value))))])
|
||||
(hash-ref marshall-unmarshall p (λ () (k value))))])
|
||||
(marshaller value))))
|
||||
|
||||
(define-struct preferences:snapshot (x))
|
||||
(define snapshot-grabbed? #f)
|
||||
(define (preferences:get-prefs-snapshot)
|
||||
(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)
|
||||
(define (preferences:restore-prefs-snapshot snapshot)
|
||||
(multi-set (map car (preferences:snapshot-x snapshot))
|
||||
(map cdr (preferences:snapshot-x snapshot)))
|
||||
(void))
|
||||
|
||||
|
||||
(provide/contract/docs
|
||||
(preferences:snapshot?
|
||||
(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.}))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))])))
|
||||
|
|
|
|||
|
|
@ -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[]
|
||||
|
|
|
|||
10
collects/scribblings/framework/gui-utils.scrbl
Normal file
10
collects/scribblings/framework/gui-utils.scrbl
Normal 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"))
|
||||
10
collects/scribblings/framework/preferences-text.scrbl
Normal file
10
collects/scribblings/framework/preferences-text.scrbl
Normal 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"))
|
||||
Loading…
Reference in New Issue
Block a user