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

Compare commits

base: suzanne.soy:doc-changes
Branches Tags
suzanne.soy:master
suzanne.soy:try-fix-popup-glitch
suzanne.soy:doc-changes
suzanne.soy:more-ellipses
suzanne.soy:v6.6
suzanne.soy:v6.5
suzanne.soy:v6.4
suzanne.soy:v6.3
suzanne.soy:v6.2
..
compare: suzanne.soy:master
Branches Tags
suzanne.soy:try-fix-popup-glitch
suzanne.soy:doc-changes
suzanne.soy:more-ellipses
suzanne.soy:master
suzanne.soy:v6.6
suzanne.soy:v6.5
suzanne.soy:v6.4
suzanne.soy:v6.3
suzanne.soy:v6.2

No commits in common. "doc-changes" and "master" have entirely different histories.
doc-change ... master

87 changed files with 2691 additions and 4010 deletions
Show Stats Expand all files Collapse all files

8
gui-doc/mrlib/scribblings/image-core.scrbl
View File

@ -51,11 +51,3 @@ up an image.
to short-circuit the full check. (The full check draws the two images to short-circuit the full check. (The full check draws the two images
and then compares the resulting bitmaps.) and then compares the resulting bitmaps.)
} }
@defthing[snip-class (is-a?/c snip-class%)]{
The snipclass used by images (which are @racket[snip%]s) created by this library.
Not all @racket[image?] values are @racket[snip%]s, but those that are use this as
their @racket[snip-class%].
}

1
gui-doc/mrlib/scribblings/mrlib.scrbl
View File

@ -21,7 +21,6 @@
@include-section["image-core.scrbl"] @include-section["image-core.scrbl"]
@include-section["matrix-snip.scrbl"] @include-section["matrix-snip.scrbl"]
@include-section["snip-canvas.scrbl"] @include-section["snip-canvas.scrbl"]
@include-section["syntax-browser.scrbl"]
@include-section["tex-table.scrbl"] @include-section["tex-table.scrbl"]
@include-section["terminal.scrbl"] @include-section["terminal.scrbl"]

2
gui-doc/mrlib/scribblings/switchable-button.scrbl
View File

@ -8,7 +8,7 @@
@defclass[switchable-button% canvas% ()]{ @defclass[switchable-button% canvas% ()]{
A @racket[switchable-button%] control displays A @racket[switchable-button%] control displays
an icon and a string label. It toggles between and icon and a string label. It toggles between
display of just the icon and a display with the display of just the icon and a display with the
label and the icon side-by-side. label and the icon side-by-side.

20
gui-doc/mrlib/scribblings/syntax-browser.scrbl
View File

@ -1,20 +0,0 @@
#lang scribble/doc
@(require "common.rkt" (for-label mrlib/image-core))
@title{Syntax Browser}
@defmodule[mrlib/syntax-browser]
@defproc[(render-syntax/snip [stx syntax?]) (is-a?/c snip%)]{
Constructs a @racket[snip%] object that displays information
about @racket[stx].
}
@defproc[(render-syntax/window [stx syntax?]) void?]{ Uses
@racket[render-syntax/snip]'s result, together with a frame
and editor-canvas to show @racket[stx].
}
@defthing[snip-class (is-a?/c snip-class%)]{
The snipclass used by the result of @racket[render-syntax/snip].
}

45
gui-doc/scribblings/framework/color.scrbl
View File

@ -41,8 +41,7 @@
component of the token. If the second value returned by component of the token. If the second value returned by
@racket[get-token] is @racket['symbol] and this value is a string @racket[get-token] is @racket['symbol] and this value is a string
then the value is used to differentiate between symbols and keywords then the value is used to differentiate between symbols and keywords
for the purpose of coloring and formatting, configurable from DrRacket's for the purpose of coloring and formatting, configurable from DrRacket's preference's editing menu.}
preference's editing menu.}
@item{A symbol describing the type of the token. This symbol is @item{A symbol describing the type of the token. This symbol is
transformed into a style-name via the @racket[token-sym->style] argument. transformed into a style-name via the @racket[token-sym->style] argument.
The symbols @racket['white-space] and @racket['comment] have special The symbols @racket['white-space] and @racket['comment] have special
@ -54,7 +53,7 @@
@item{A symbol indicating how the token should be treated by the paren @item{A symbol indicating how the token should be treated by the paren
matcher or @racket[#f]. This symbol should be in the pairs argument.} matcher or @racket[#f]. This symbol should be in the pairs argument.}
@item{The starting position of the token (or @racket[#f] if eof); this @item{The starting position of the token (or @racket[#f] if eof); this
number is relative to the third result of @racket[port-next-location] number is relative to the third result of @racket[get-port-location]
when applied to the input port that gets passed to @racket[get-token].} when applied to the input port that gets passed to @racket[get-token].}
@item{The ending position of the token (or @racket[#f] if eof); this @item{The ending position of the token (or @racket[#f] if eof); this
is also relative to the port's location, just like the previous value.}] is also relative to the port's location, just like the previous value.}]
@ -64,12 +63,7 @@
The offset given to @racket[get-token] can be added The offset given to @racket[get-token] can be added
to the position of the input port to obtain absolute coordinates within a to the position of the input port to obtain absolute coordinates within a
text stream. The extra two results are text stream. The extra two results are
@itemize[@item{a backup distance; @itemize[@item{a new mode;
The backup distance returned by @racket[get-token] indicates the
maximum number of characters to back up (counting from the start of the
token) and for re-parsing after a change to the editor within the token's
region.}
@item{a new mode;
The mode argument allows @racket[get-token] to communicate The mode argument allows @racket[get-token] to communicate
information from earlier parsing to later. When @racket[get-token] is information from earlier parsing to later. When @racket[get-token] is
called for the beginning on a stream, the mode argument is @racket[#f]; called for the beginning on a stream, the mode argument is @racket[#f];
@ -89,7 +83,12 @@
The mode should not be a mutable The mode should not be a mutable
value; if part of the stream is re-tokenized, the mode saved from the value; if part of the stream is re-tokenized, the mode saved from the
immediately preceding token is given again to the @racket[get-token] immediately preceding token is given again to the @racket[get-token]
function.}] function.}
@item{a backup distance;
The backup distance returned by @racket[get-token] indicates the
maximum number of characters to back up (counting from the start of the
token) and for re-parsing after a change to the editor within the token's
region.}]
The @racket[get-token] function must obey the following invariants: The @racket[get-token] function must obey the following invariants:
@itemize[ @itemize[
@ -188,14 +187,11 @@
background after the call to @racket[thaw-colorer] returns. background after the call to @racket[thaw-colorer] returns.
} }
@defmethod[(reset-region (start exact-nonnegative-integer?) @defmethod[(reset-region (start exact-nonnegative-integer?) (end (or/c exact-nonnegative-integer? 'end))) void?]{
(end (or/c exact-nonnegative-integer? 'end))) void?]{
Set the region of the text that is tokenized. Set the region of the text that is tokenized.
} }
@defmethod[(reset-regions [regions (listof (list/c exact-nonnegative-integer? @defmethod[(reset-regions (regions (listof (list/c exact-nonnegative-integer? (or/c exact-nonnegative-integer? 'end))))) void?]{
(or/c exact-nonnegative-integer? 'end)))])
void?]{
Sets the currently active regions to be @racket[regions]. Sets the currently active regions to be @racket[regions].
} }
@ -241,8 +237,7 @@
spell checking is disabled, returns @racket[#f]. spell checking is disabled, returns @racket[#f].
} }
@defmethod[(get-regions) @defmethod[(get-regions) (listof (list/c exact-nonnegative-integer? (or/c exact-nonnegative-integer? 'end)))]{
(listof (list/c exact-nonnegative-integer? (or/c exact-nonnegative-integer? 'end)))]{
This returns the list of regions that are currently being colored in the This returns the list of regions that are currently being colored in the
editor. editor.
@ -260,8 +255,7 @@
Must only be called while the tokenizer is started. Must only be called while the tokenizer is started.
} }
@defmethod[(backward-match [position exact-nonnegative-integer?] @defmethod[(backward-match [position exact-nonnegative-integer?] [cutoff exact-nonnegative-integer?])
[cutoff exact-nonnegative-integer?])
(or/c exact-nonnegative-integer? #f)]{ (or/c exact-nonnegative-integer? #f)]{
Skip all consecutive whitespaces and comments (using Skip all consecutive whitespaces and comments (using
@ -272,8 +266,7 @@
Must only be called while the tokenizer is started. Must only be called while the tokenizer is started.
} }
@defmethod[(backward-containing-sexp [position exact-nonnegative-integer?] @defmethod[(backward-containing-sexp [position exact-nonnegative-integer?] [cutoff exact-nonnegative-integer?])
[cutoff exact-nonnegative-integer?])
(or/c exact-nonnegative-integer? #f)]{ (or/c exact-nonnegative-integer? #f)]{
Return the starting position of the interior of the (non-atomic) Return the starting position of the interior of the (non-atomic)
@ -376,15 +369,7 @@
@defclass[color:text% (color:text-mixin text:keymap%) ()]{} @defclass[color:text% (color:text-mixin text:keymap%) ()]{}
@definterface[color:text-mode<%> ()]{ @definterface[color:text-mode<%> ()]{}
@defmethod[(set-get-token [get-token procedure?]) void?]{
Sets the @racket[get-token] function used to color the contents
of the editor.
See @method[color:text<%> start-colorer]'s @racket[get-token] argument
for the contract on this method's @racket[get-token] argument.
}
}
@defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
This mixin adds coloring functionality to the mode. This mixin adds coloring functionality to the mode.

77
gui-doc/scribblings/framework/text.scrbl
View File

@ -1,6 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual scribble/extract) @(require scribble/manual scribble/extract)
@(require (for-label framework racket/gui racket/contract/base)) @(require (for-label framework racket/gui))
@title{Text} @title{Text}
@definterface[text:basic<%> (editor:basic<%> text%)]{ @definterface[text:basic<%> (editor:basic<%> text%)]{
@ -139,43 +139,24 @@
} }
@defmethod[(move/copy-to-edit [dest-text (is-a?/c text%)] @defmethod[(move/copy-to-edit [dest-text (is-a?/c text%)]
[start natural?] [start exact-integer?]
[end (and/c natural? (>=/c start))] [end exact-integer?]
[dest-pos natural?] [dest-pos exact-integer?]
[#:try-to-move? try-to-move? boolean? #t]) [#:try-to-move? try-to-move? boolean? #t])
void?]{ void?]{
This moves or copies text and snips to @racket[dest-text]. This moves or copies text and snips to another edit.
Moves or copies from @racket[this] starting at @racket[start] and ending at Moves or copies from the edit starting at @racket[start] and ending at
@racket[end]. It puts the copied text and snips in @racket[dest-text] @racket[end]. It puts the copied text and snips in @racket[dest-text]
starting at location @racket[dest-pos]. If @racket[start] and @racket[end] starting at location @racket[dest-pos].
are equal then nothing is moved or copied.
If @racket[try-to-move?] is @racket[#t], then the snips are removed; If @racket[try-to-move] is @racket[#t], then the snips are removed;
and if it is @racket[#f], then they are copied. If @racket[try-to-move?] is and if it is @racket[#f], then they are copied.
@racket[#t] and @racket[dest-pos] is between @racket[start] and @racket[end]
then @racket[this] is unchanged.
If a snip refuses to be moved, it will be copied and deleted from the editor, If a snip refused to be moved, it will be copied and deleted from the editor,
otherwise it will be moved. A snip may refuse to be moved by returning otherwise it will be moved. A snip may refuse to be moved by returning
@racket[#f] from @method[snip% release-from-owner]. @racket[#f] from @method[snip% release-from-owner].
} }
@defmethod[(move-to [dest-text (is-a?/c text%)]
[start natural?]
[end (and/c natural? (>=/c start))]
[dest-pos natural?])
void?]{
Like @method[text:basic<%> move/copy-to-edit] when the @racket[#:try-to-move?]
argument is @racket[#t].
}
@defmethod[(copy-to [dest-text (is-a?/c text%)]
[start natural?]
[end (and/c natural? (>=/c start))]
[dest-pos natural?])
void?]{
Like @method[text:basic<%> move/copy-to-edit] when the @racket[#:try-to-move?]
argument is @racket[#f].
}
@defmethod*[(((initial-autowrap-bitmap) (or/c #f (is-a?/c bitmap%))))]{ @defmethod*[(((initial-autowrap-bitmap) (or/c #f (is-a?/c bitmap%))))]{
The result of this method is used as the initial autowrap bitmap. Override The result of this method is used as the initial autowrap bitmap. Override
@ -558,7 +539,7 @@
@definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{ @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
Any object matching this interface can be searched. Any object matching this interface can be searched.
@defmethod[(set-searching-state [str (or/c #f non-empty-string?)] @defmethod[(set-searching-state [str (or/c #f (and/c string? (not/c "")))]
[cs? boolean?] [cs? boolean?]
[replace-mode? boolean?] [replace-mode? boolean?]
[notify-frame? boolean?]) [notify-frame? boolean?])
@ -595,40 +576,22 @@
Returns the number of hits for the search in the buffer before the Returns the number of hits for the search in the buffer before the
insertion point and the total number of hits. Both are based on the count insertion point and the total number of hits. Both are based on the count
found last time that a search completed. found last time that a search completed.
A search initiated by some earlier change to the editor or
to the string to search for may make the results of this
method obsolete. To force those changes to complete (and
thus get an accurate result from this method) call
@method[text:searching<%> finish-pending-search-work].
} }
@defmethod[(get-replace-search-hit) (or/c number? #f)]{ @defmethod[(get-replace-search-hit) (or/c number? #f)]{
Returns the position of the nearest search hit that comes after the Returns the position of the nearest search hit that comes after the
insertion point. insertion point.
}
A search initiated by some earlier change to the editor or
to the string to search for may make the results of this
method obsolete. To force those changes to complete (and
thus get an accurate result from this method) call
@method[text:searching<%> finish-pending-search-work].
}
@defmethod[(set-replace-start [pos (or/c number? #f)]) void?]{ @defmethod[(set-replace-start [pos (or/c number? #f)]) void?]{
This method is ignored. (The next replacement start is now This method is ignored. (The next replacement start is now
tracked via the @method[text% after-set-position] method.) tracked via the @method[text% after-set-position] method.)
} }
@defmethod[(finish-pending-search-work) void?]{ @defmethod[(finish-pending-search-work) void?]{
Finishes any pending work in computing and drawing the Finishes any pending work in computing and
search bubbles. drawing the search bubbles.
}
Call this method to ensure that the results from any of
@method[text:searching<%> get-search-hit-count],
@method[text:searching<%> get-replace-search-hit], or
@method[text:searching<%> get-search-bubbles] are correct.
}
@defmethod[(get-search-bubbles) @defmethod[(get-search-bubbles)
(listof (list/c (cons/c number? number?) (listof (list/c (cons/c number? number?)
@ -640,12 +603,6 @@
the range of the bubble and the symbol is the color of the the range of the bubble and the symbol is the color of the
bubble. bubble.
A search initiated by some earlier change to the editor or
to the string to search for may make the results of this
method obsolete. To force those changes to complete (and
thus get an accurate result from this method) call
@method[text:searching<%> finish-pending-search-work].
This method is intended for use in test suites. This method is intended for use in test suites.
} }
} }
@ -1457,7 +1414,7 @@
} }
} }
@defmixin[text:line-numbers-mixin (text% editor:standard-style-list<%>) (text:line-numbers<%>)]{ @defmixin[text:line-numbers-mixin (text%) (text:line-numbers<%>)]{
@defmethod*[#:mode override (((on-paint) void?))]{ @defmethod*[#:mode override (((on-paint) void?))]{
Draws the line numbers. Draws the line numbers.

2
gui-doc/scribblings/gui/blurbs.rkt
View File

@ -27,7 +27,7 @@
@elem{If @litchar{&} occurs in @|where|, it is specially parsed; @elem{If @litchar{&} occurs in @|where|, it is specially parsed;
under Windows and X, the character under Windows and X, the character
following @litchar{&} is underlined in the displayed control to following @litchar{&} is underlined in the displayed control to
indicate a keyboard mnemonic. (Under Mac OS, mnemonic underlines are indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are
not shown.) The mnemonic is meaningless for a @|what| (as far as not shown.) The mnemonic is meaningless for a @|what| (as far as
@xmethod[top-level-window<%> on-traverse-char] is concerned), @xmethod[top-level-window<%> on-traverse-char] is concerned),
but it is supported for consistency with other control types. A but it is supported for consistency with other control types. A

7
gui-doc/scribblings/gui/button-class.scrbl
View File

@ -36,7 +36,7 @@ Creates a button with a string label, bitmap label, or both.
If @litchar{&} occurs in @racket[label] (when @racket[label] includes a If @litchar{&} occurs in @racket[label] (when @racket[label] includes a
string), it is specially parsed; on Windows and Unix, the character string), it is specially parsed; on Windows and Unix, the character
following @litchar{&} is underlined in the displayed control to following @litchar{&} is underlined in the displayed control to
indicate a keyboard mnemonic. (On Mac OS, mnemonic underlines are indicate a keyboard mnemonic. (On Mac OS X, mnemonic underlines are
not shown.) The underlined mnemonic character must be a letter or a not shown.) The underlined mnemonic character must be a letter or a
digit. The user can effectively click the button by typing the digit. The user can effectively click the button by typing the
mnemonic when the control's top-level-window contains the keyboard mnemonic when the control's top-level-window contains the keyboard
@ -45,13 +45,14 @@ keyboard focus is currently in a control that handles normal
alphanumeric input. The @litchar{&} itself is removed from alphanumeric input. The @litchar{&} itself is removed from
@racket[label] before it is displayed for the control; a @litchar{&&} @racket[label] before it is displayed for the control; a @litchar{&&}
in @racket[label] is converted to @litchar{&} (with no mnemonic in @racket[label] is converted to @litchar{&} (with no mnemonic
underlining). On Mac OS, a parenthesized mnemonic character is underlining). On Mac OS X, a parenthesized mnemonic character is
removed (along with any surrounding space) before the label is removed (along with any surrounding space) before the label is
displayed, since a parenthesized mnemonic is often used for non-Roman displayed, since a parenthesized mnemonic is often used for non-Roman
languages. Finally, for historical reasons, any text after a tab character is removed on all languages. Finally, for historical reasons, any text after a tab character is removed on all
platforms. All of these rules are consistent with label handling in platforms. All of these rules are consistent with label handling in
menu items (see @method[labelled-menu-item<%> set-label]). Mnemonic keyboard events are handled by menu items (see @method[labelled-menu-item<%> set-label]). Mnemonic keyboard events are handled by
@method[top-level-window<%> on-traverse-char] (but not on Mac OS). @method[top-level-window<%> on-traverse-char] (but not on Mac OS
X).
The @racket[callback] procedure is called (with the event type The @racket[callback] procedure is called (with the event type
@indexed-racket['button]) whenever the user clicks the button. @indexed-racket['button]) whenever the user clicks the button.

2
gui-doc/scribblings/gui/canvas-class.scrbl
View File

@ -107,7 +107,7 @@ Returns the canvas's drawing-area dimensions in OpenGL units for a
The result is the same as @method[canvas<%> get-scaled-client-size] The result is the same as @method[canvas<%> get-scaled-client-size]
in a canvas without the @racket['gl] style or on Windows and Unix. On in a canvas without the @racket['gl] style or on Windows and Unix. On
Mac OS, the result can be the same as @method[window<%> Mac OS X, the result can be the same as @method[window<%>
get-client-size] if the @racket[gl-config%] specification provided on get-client-size] if the @racket[gl-config%] specification provided on
creation does not specify high-resolution mode. creation does not specify high-resolution mode.

6
gui-doc/scribblings/gui/canvas-intf.scrbl
View File

@ -144,7 +144,7 @@ Returns the canvas's drawing-area dimensions in unscaled pixels---that
is, without scaling (see @secref["display-resolution"]) that is is, without scaling (see @secref["display-resolution"]) that is
implicitly applied to the canvas size and content. implicitly applied to the canvas size and content.
For example, when a canvas on Mac OS resides on a Retina display, it For example, when a canvas on Mac OS X resides on a Retina display, it
has a backing scale of @racket[2], and so the results from has a backing scale of @racket[2], and so the results from
@method[canvas<%> get-scaled-client-size] will be twice as large as results from @method[canvas<%> get-scaled-client-size] will be twice as large as results from
@method[window<%> get-client-size]. If the same canvas's frame is dragged to a @method[window<%> get-client-size]. If the same canvas's frame is dragged to a
@ -155,7 +155,7 @@ a canvas's backing scale can change depends on the platform.
The size reported by @method[canvas<%> get-scaled-client-size] may match The size reported by @method[canvas<%> get-scaled-client-size] may match
a viewport size for OpenGL drawing in @racket[canvas%] instance with a viewport size for OpenGL drawing in @racket[canvas%] instance with
the @racket['gl] style. On Mac OS, however, the viewport will match the @racket['gl] style. On Mac OS X, however, the viewport will match
the scaled size unless the canvas is created with a the scaled size unless the canvas is created with a
@racket[gl-config%] specification that is adjusted to high-resolution @racket[gl-config%] specification that is adjusted to high-resolution
mode via @method[gl-config% set-hires-mode]. See also mode via @method[gl-config% set-hires-mode]. See also
@ -300,7 +300,7 @@ If the canvas was created with the @indexed-racket['transparent] style,
@defmethod[(set-resize-corner [on? any/c]) @defmethod[(set-resize-corner [on? any/c])
void?]{ void?]{
On Mac OS, enables or disables space for a resize tab at the On Mac OS X, enables or disables space for a resize tab at the
canvas's lower-right corner when only one scrollbar is visible. This canvas's lower-right corner when only one scrollbar is visible. This
method has no effect on Windows or Unix, and it has no effect when method has no effect on Windows or Unix, and it has no effect when
both or no scrollbars are visible. The resize corner is disabled by both or no scrollbars are visible. The resize corner is disabled by

2
gui-doc/scribblings/gui/clipboard-client-class.scrbl
View File

@ -25,7 +25,7 @@ Adds a new data format name to the list supported by the clipboard
client. client.
The @racket[format] string is typically four capital letters. (On The @racket[format] string is typically four capital letters. (On
Mac OS, only four characters for @racket[format] are ever used.) Mac OS X, only four characters for @racket[format] are ever used.)
For example, @racket["TEXT"] is the name of the UTF-8-encoded string For example, @racket["TEXT"] is the name of the UTF-8-encoded string
format. New format names can be used to communicate application- and format. New format names can be used to communicate application- and
platform-specific data formats. platform-specific data formats.

6
gui-doc/scribblings/gui/clipboard-intf.scrbl
View File

@ -14,7 +14,7 @@ On Unix, a second @racket[clipboard<%>] object,
@racket[the-x-selection-clipboard], and the system-wide X11 clipboard @racket[the-x-selection-clipboard], and the system-wide X11 clipboard
is not used. is not used.
On Windows and Mac OS, @racket[the-x-selection-clipboard] is On Windows and Mac OS X, @racket[the-x-selection-clipboard] is
always the same as @racket[the-clipboard]. always the same as @racket[the-clipboard].
Data can be entered into a clipboard in one of two ways: by setting Data can be entered into a clipboard in one of two ways: by setting
@ -31,7 +31,7 @@ Generic data is always retrieved from the clipboard as a byte
@defmethod[(get-clipboard-bitmap [time exact-integer?]) @defmethod[(get-clipboard-bitmap [time exact-integer?])
(or/c (is-a?/c bitmap%) #f)]{ (or/c (is-a?/c bitmap%) #f)]{
Gets the current clipboard contents as a bitmap (Windows, Mac OS), Gets the current clipboard contents as a bitmap (Windows, Mac OS X),
returning @racket[#f] if the clipboard does not contain a bitmap. returning @racket[#f] if the clipboard does not contain a bitmap.
See See
@ -92,7 +92,7 @@ Returns @racket[#t] if @racket[owner] currently owns the clipboard,
[time exact-integer?]) [time exact-integer?])
void?]{ void?]{
Changes the current clipboard contents to @racket[new-bitmap] (Windows, Mac OS) Changes the current clipboard contents to @racket[new-bitmap] (Windows, Mac OS X)
and releases the current clipboard client (if any). and releases the current clipboard client (if any).
See @|timediscuss| for See @|timediscuss| for

10
gui-doc/scribblings/gui/dialog-class.scrbl
View File

@ -44,7 +44,7 @@ If @racket[parent] is @racket[#f], then the eventspace for the new
If the @racket[width] or @racket[height] argument is not @racket[#f], If the @racket[width] or @racket[height] argument is not @racket[#f],
it specifies an initial size for the dialog (in pixels) assuming that it specifies an initial size for the dialog (in pixels) assuming that
it is larger than the minimum size, otherwise the minimum size is it is larger than the minimum size, otherwise the minimum size is
used. On Windows and Mac OS (and with some Unix window managers) used. On Windows and Mac OS X (and with some Unix window managers)
dialogs are not resizeable. dialogs are not resizeable.
If the @racket[x] or @racket[y] argument is not @racket[#f], it If the @racket[x] or @racket[y] argument is not @racket[#f], it
@ -61,14 +61,14 @@ The @racket[style] flags adjust the appearance of the dialog on some
(Windows)} (Windows)}
@item{@racket['resize-border] --- adds a resizeable border around the @item{@racket['resize-border] --- adds a resizeable border around the
window (Windows), ability to resize the window (Mac OS), or grow window (Windows), ability to resize the window (Mac OS X), or grow
box in the bottom right corner (older Mac OS)} box in the bottom right corner (older Mac OS X)}
@item{@racket['no-sheet] --- uses a movable window for the dialog, @item{@racket['no-sheet] --- uses a movable window for the dialog,
even if a parent window is provided (Mac OS)} even if a parent window is provided (Mac OS X)}
@item{@racket['close-button] --- include a close button in the @item{@racket['close-button] --- include a close button in the
dialog's title bar, which would not normally be included (Mac OS)} dialog's title bar, which would not normally be included (Mac OS X)}
] ]

15
gui-doc/scribblings/gui/dialog-funcs.scrbl
View File

@ -45,7 +45,7 @@ Under Windows, if @racket[extension] is not @racket[#f], the returned path
The @racket[style] list can contain @racket['common], a The @racket[style] list can contain @racket['common], a
platform-independent version of the dialog is used instead of a platform-independent version of the dialog is used instead of a
native dialog. On Mac OS, if the @racket[style] list native dialog. On Mac OS X, if the @racket[style] list
contains @racket['packages], a user is allowed to select a package contains @racket['packages], a user is allowed to select a package
directory, which is a directory with a special suffix (e.g., directory, which is a directory with a special suffix (e.g.,
``.app'') that the Finder normally displays like a file. If the list ``.app'') that the Finder normally displays like a file. If the list
@ -62,7 +62,7 @@ On Windows and Unix, @racket[filters] determines a set of filters from
regular expressions and can only be used with a @litchar["*"] wildcard regular expressions and can only be used with a @litchar["*"] wildcard
character. For example, @racket["*.jp*g;*.png"]. character. For example, @racket["*.jp*g;*.png"].
On Unix, a @racket["*.*"] pattern is implicitly replaced with @racket["*"]. On Unix, a @racket["*.*"] pattern is implicitly replaced with @racket["*"].
On Mac OS, suffix names are extracted from all globs that match a On Mac OS X, suffix names are extracted from all globs that match a
fixed suffix (e.g., two suffixes of @racket["foo"] and @racket["bar"] fixed suffix (e.g., two suffixes of @racket["foo"] and @racket["bar"]
are extracted from a @racket["*.foo;*.bar;*.baz*"] pattern), and files are extracted from a @racket["*.foo;*.bar;*.baz*"] pattern), and files
that have any of these suffixes in any filter are selectable; a that have any of these suffixes in any filter are selectable; a
@ -133,7 +133,7 @@ On Windows, if @racket[extension] is not @racket[#f], the returned path
is @racket[(string-append "*." extension)], then the result pathname is guaranteed is @racket[(string-append "*." extension)], then the result pathname is guaranteed
to have an extension mapping @racket[extension]. to have an extension mapping @racket[extension].
On Mac OS 10.5 and later, if @racket[extension] is not On Mac OS X 10.5 and later, if @racket[extension] is not
@racket[#f] or @racket[""], the returned path will get a default extension if the @racket[#f] or @racket[""], the returned path will get a default extension if the
user does not supply one. If @racket[filters] contains as user does not supply one. If @racket[filters] contains as
@racket["*.*"] pattern, then the user can supply any extension that @racket["*.*"] pattern, then the user can supply any extension that
@ -145,7 +145,7 @@ On Mac OS 10.5 and later, if @racket[extension] is not
"*." extension)], then the result pathname is guaranteed to have an "*." extension)], then the result pathname is guaranteed to have an
extension mapping @racket[extension]. extension mapping @racket[extension].
On Mac OS versions before 10.5, the returned path will get a On Mac OS X versions before 10.5, the returned path will get a
default extension only if @racket[extension] is not @racket[#f], default extension only if @racket[extension] is not @racket[#f],
@racket[extension] is not @racket[""], and @racket[extension] is not @racket[""], and
@racket[filters] contains only @racket[(string-append "*." @racket[filters] contains only @racket[(string-append "*."
@ -183,7 +183,7 @@ If @racket[directory] is not @racket[#f], it is used on some platforms as
The @racket[style] argument is treated as for The @racket[style] argument is treated as for
@racket[get-file], except that only @racket['common] or @racket['enter-packages] can be @racket[get-file], except that only @racket['common] or @racket['enter-packages] can be
specified. The latter specified. The latter
matters only on Mac OS, where @racket['enter-packages] matters only on Mac OS X, where @racket['enter-packages]
enables the user to select package directory or a directory within a enables the user to select package directory or a directory within a
package. A package is a directory with a special suffix (e.g., package. A package is a directory with a special suffix (e.g.,
``.app'') that the Finder normally displays like a file. ``.app'') that the Finder normally displays like a file.
@ -295,7 +295,8 @@ If @racket[style] does not include @racket['number-order], the order of
@item{Button 1 is the normal action, and it is usually the default @item{Button 1 is the normal action, and it is usually the default
button. For example, if the dialog has an @onscreen{OK} button, it is button. For example, if the dialog has an @onscreen{OK} button, it is
this one. On Windows, this button is leftmost; on Unix and Mac OS, it is rightmost. (See also this one. On Windows, this button is leftmost; on Unix and Mac OS
X, it is rightmost. (See also
@racket[system-position-ok-before-cancel?].) Use this button for @racket[system-position-ok-before-cancel?].) Use this button for
dialogs that contain only one button.} dialogs that contain only one button.}
@ -304,7 +305,7 @@ If @racket[style] does not include @racket['number-order], the order of
when confirming a file replacement).} when confirming a file replacement).}
@item{Button 3 tends to be separated from the other two (on @item{Button 3 tends to be separated from the other two (on
Mac OS, it is left-aligned in the dialog). Use this button only Mac OS X, it is left-aligned in the dialog). Use this button only
for three-button dialogs.} for three-button dialogs.}
] ]

5
gui-doc/scribblings/gui/editor-funcs.scrbl
View File

@ -179,7 +179,7 @@ Gets the snip class list instance for the current eventspace.
[(map-command-as-meta-key) [(map-command-as-meta-key)
boolean?])]{ boolean?])]{
Determines the interpretation of @litchar{m:} for a @racket[keymap%] Determines the interpretation of @litchar{m:} for a @racket[keymap%]
mapping on Mac OS. See also mapping on Mac OS X. See also
@xmethod[keymap% map-function]. @xmethod[keymap% map-function].
@ -187,7 +187,8 @@ First case:
If @racket[on?] is @racket[#t], @litchar{m:} corresponds to the Command key. If If @racket[on?] is @racket[#t], @litchar{m:} corresponds to the Command key. If
@racket[on?] is @racket[#f], then @litchar{m:} corresponds to no key on Mac OS. @racket[on?] is @racket[#f], then @litchar{m:} corresponds to no key on Mac OS
X.

6
gui-doc/scribblings/gui/editor-intf.scrbl
View File

@ -30,10 +30,6 @@ Adds an undoer procedure to the editor's undo stack. If an undo is
redoing) changes to an editor, and when this undoer is the first item redoing) changes to an editor, and when this undoer is the first item
on the undo (or redo) stack. on the undo (or redo) stack.
Editor instances are created with no undo stack, so no undo operations
will be recorded unless @method[editor<%> set-max-undo-history] is
used to change the size of the undo stack.
The system automatically installs undo records to undo built-in editor The system automatically installs undo records to undo built-in editor
operations, such as inserts, deletes, and font changes. Install an operations, such as inserts, deletes, and font changes. Install an
undoer only when it is necessary to maintain state or handle undoer only when it is necessary to maintain state or handle
@ -2064,7 +2060,7 @@ The filename and format used to save the file can be retrieved with
See also @method[editor<%> on-save-file], @method[editor<%> See also @method[editor<%> on-save-file], @method[editor<%>
after-save-file], and @method[editor<%> can-save-file?]. after-save-file], and @method[editor<%> can-save-file?].
On Mac OS, the file's type signature is set to @racket["TEXT"] On Mac OS X, the file's type signature is set to @racket["TEXT"]
for a text-format file or @racket["WXME"] for a standard-format for a text-format file or @racket["WXME"] for a standard-format
(binary) file. (binary) file.

28
gui-doc/scribblings/gui/editor-overview.scrbl
View File

@ -61,9 +61,9 @@ A brief example illustrates how editors work. To start, an editor
] ]
At this point, the editor is fully functional: the user can type text At this point, the editor is fully functional: the user can type text
into the editor, but no cut-and-paste or undo operations are into the editor, but no cut-and-paste operations are available. We
available. We can support all of the standard operations on an editor can support all of the standard operations on an editor via the
via the menu bar: menu bar:
@racketblock[ @racketblock[
(define mb (new menu-bar% [parent f])) (define mb (new menu-bar% [parent f]))
@ -71,20 +71,16 @@ At this point, the editor is fully functional: the user can type text
(define m-font (new menu% [label "Font"] [parent mb])) (define m-font (new menu% [label "Font"] [parent mb]))
(append-editor-operation-menu-items m-edit #f) (append-editor-operation-menu-items m-edit #f)
(append-editor-font-menu-items m-font) (append-editor-font-menu-items m-font)
(send t #,(:: editor<%> set-max-undo-history) 100)
] ]
Now, the standard cut-and-paste operations work and so does undo, and Now, the standard cut and paste operations work, and the user can even
the user can even set font styles. The editor is created with no undo set font styles. The user can also insert an embedded editor by
history stack, @method[editor<%> set-max-undo-history] is used to set selecting @onscreen{Insert Text} from the @onscreen{Edit} menu; after
a non-zero stack, so undo operations can be recorded. The user can selecting the menu item, a box appears in the editor with the caret
also insert an embedded editor by selecting @onscreen{Insert Text} inside. Typing with the caret in the box stretches the box as text is
from the @onscreen{Edit} menu; after selecting the menu item, a box added, and font operations apply wherever the caret is active. Text
appears in the editor with the caret inside. Typing with the caret in on the outside of the box is rearranged as the box changes
the box stretches the box as text is added, and font operations apply sizes. Note that the box itself can be copied and pasted.
wherever the caret is active. Text on the outside of the box is
rearranged as the box changes sizes. Note that the box itself can be
copied and pasted.
The content of an editor is made up of @defterm{@tech{snips}}. An The content of an editor is made up of @defterm{@tech{snips}}. An
embedded editor is a single snip from the embedding editor's embedded editor is a single snip from the embedding editor's
@ -590,7 +586,7 @@ Text can be extracted from an editor in either of two forms:
mapped to themselves, but more complicated @techlink{item}s can be mapped to themselves, but more complicated @techlink{item}s can be
represented with a useful string determined by the @techlink{item}'s represented with a useful string determined by the @techlink{item}'s
snip. Newlines are mapped to platform-specific character sequences snip. Newlines are mapped to platform-specific character sequences
(linefeed on Unix and Mac OS, and (linefeed on Unix and Mac OS X, and
linefeed--carriage return on Windows). This form is called linefeed--carriage return on Windows). This form is called
``flattened'' because the editor's @techlink{item}s have been reduced ``flattened'' because the editor's @techlink{item}s have been reduced
to a linear sequence of characters.} to a linear sequence of characters.}

6
gui-doc/scribblings/gui/eventspace-funcs.scrbl
View File

@ -65,7 +65,7 @@ the eventspace @racket[e] itself.
@defproc[(check-for-break) @defproc[(check-for-break)
boolean?]{ boolean?]{
Inspects the event queue of the current eventspace, searching for a Inspects the event queue of the current eventspace, searching for a
Shift-Ctl-C (Unix, Windows) or Cmd-. (Mac OS) key combination. Returns Shift-Ctl-C (Unix, Windows) or Cmd-. (Mac OS X) key combination. Returns
@racket[#t] if such an event was found (and the event is dequeued) or @racket[#t] if such an event was found (and the event is dequeued) or
@racket[#f] otherwise. @racket[#f] otherwise.
@ -101,7 +101,7 @@ Returns the top level window in the current eventspace that is visible
boolean?])]{ boolean?])]{
For backward compatibility, only. This function was intended to enable For backward compatibility, only. This function was intended to enable
or disable special Control key handling (Mac OS), but it currently or disable special Control key handling (Mac OS X), but it currently
has no effect. has no effect.
} }
@ -111,7 +111,7 @@ has no effect.
[(special-option-key) [(special-option-key)
boolean?])]{ boolean?])]{
Enables or disables special Option key handling (Mac OS). When Enables or disables special Option key handling (Mac OS X). When
Option is treated as a special key, the @method[key-event% Option is treated as a special key, the @method[key-event%
get-key-code] and @method[key-event% get-other-altgr-key-code] get-key-code] and @method[key-event% get-other-altgr-key-code]
results are effectively swapped when the Option key is pressed. By results are effectively swapped when the Option key is pressed. By

6
gui-doc/scribblings/gui/font-funcs.scrbl
View File

@ -7,7 +7,7 @@
This font is the default for @racket[popup-menu%] objects. This font is the default for @racket[popup-menu%] objects.
On Mac OS, this font is slightly larger than On Mac OS X, this font is slightly larger than
@racket[normal-control-font]. On Windows and Unix, it is the same @racket[normal-control-font]. On Windows and Unix, it is the same
size as @racket[normal-control-font]. size as @racket[normal-control-font].
@ -28,7 +28,7 @@ This font is the default for @racket[group-box-panel%] objects, and it is
On Windows, this font is the same size as On Windows, this font is the same size as
@racket[normal-control-font], since the Windows control font is @racket[normal-control-font], since the Windows control font is
already relatively small. On Unix and Mac OS, this font is slightly already relatively small. On Unix and Mac OS X, this font is slightly
smaller than @racket[normal-control-font]. smaller than @racket[normal-control-font].
@ -46,7 +46,7 @@ This font is for tiny controls, and it is smaller than
This font is the default for @racket[list-box%] objects (but not This font is the default for @racket[list-box%] objects (but not
list box labels, which use @racket[normal-control-font]). list box labels, which use @racket[normal-control-font]).
On Mac OS, this font is slightly smaller than On Mac OS X, this font is slightly smaller than
@racket[normal-control-font], and slightly larger than @racket[normal-control-font], and slightly larger than
@racket[small-control-font]. On Windows and Unix, it is the same size @racket[small-control-font]. On Windows and Unix, it is the same size
as @racket[normal-control-font]. as @racket[normal-control-font].

30
gui-doc/scribblings/gui/frame-class.scrbl
View File

@ -61,37 +61,37 @@ some platforms:
@item{@racket['no-resize-border] --- omits the resizeable border @item{@racket['no-resize-border] --- omits the resizeable border
around the window (Windows, Unix), ability to resize the window (Mac around the window (Windows, Unix), ability to resize the window (Mac
OS), or grow box in the bottom right corner (older Mac OS)} OS X), or grow box in the bottom right corner (older Mac OS X)}
@item{@racket['no-caption] --- omits the title bar for the frame @item{@racket['no-caption] --- omits the title bar for the frame
(Windows, Mac OS, Unix)} (Windows, Mac OS X, Unix)}
@item{@racket['no-system-menu] --- omits the system menu @item{@racket['no-system-menu] --- omits the system menu
(Windows)} (Windows)}
@item{@racket['toolbar-button] --- includes a toolbar button on the @item{@racket['toolbar-button] --- includes a toolbar button on the
frame's title bar (Mac OS 10.6 and earlier); a click on the toolbar button triggers frame's title bar (Mac OS X 10.6 and earlier); a click on the toolbar button triggers
a call to @method[frame% on-toolbar-button-click]} a call to @method[frame% on-toolbar-button-click]}
@item{@racket['hide-menu-bar] --- hides the menu bar and dock when @item{@racket['hide-menu-bar] --- hides the menu bar and dock when
the frame is active (Mac OS) or asks the window manager to make the frame is active (Mac OS X) or asks the window manager to make
the frame fullscreen (Unix)} the frame fullscreen (Unix)}
@item{@racket['float] --- causes the frame to stay in front of all @item{@racket['float] --- causes the frame to stay in front of all
other non-floating windows (Windows, Mac OS, Unix); on Mac OS, a floating frame other non-floating windows (Windows, Mac OS X, Unix); on Mac OS X, a floating frame
shares the focus with an active non-floating frame; when this style shares the focus with an active non-floating frame; when this style
is combined with @racket['no-caption], then showing the frame does is combined with @racket['no-caption], then showing the frame does
not cause the keyboard focus to shift to the window, and on Unix, not cause the keyboard focus to shift to the window, and on Unix,
clicking the frame does not move the focus; on Windows, a floating clicking the frame does not move the focus; on Windows, a floating
frame has no taskbar button} frame has no taskbar button}
@item{@racket['metal] --- ignored (formerly supported for Mac OS)} @item{@racket['metal] --- ignored (formerly supported for Mac OS X)}
@item{@racket['fullscreen-button] --- includes a button on the @item{@racket['fullscreen-button] --- includes a button on the
frame's title bar to put the frame in fullscreen mode (Mac OS 10.7 and later)} frame's title bar to put the frame in fullscreen mode (Mac OS X 10.7 and later)}
@item{@racket['fullscreen-aux] --- allows the frame to accompany @item{@racket['fullscreen-aux] --- allows the frame to accompany
another that is in fullscreen mode (Mac OS 10.7 and later)} another that is in fullscreen mode (Mac OS X 10.7 and later)}
] ]
@ -129,13 +129,13 @@ Puts the frame in fullscreen mode or restores the frame to
@Unmonitored[@elem{A frame's mode} @elem{the user} @elem{a @Unmonitored[@elem{A frame's mode} @elem{the user} @elem{a
frame has been put in fullscreen mode} @elem{@method[frame% is-fullscreened?]}] frame has been put in fullscreen mode} @elem{@method[frame% is-fullscreened?]}]
On Mac OS, the @racket[frame%] must be created with the style On Mac OS X, the @racket[frame%] must be created with the style
@racket['fullscreen-button] for fullscreen mode to work, and Mac OS @racket['fullscreen-button] for fullscreen mode to work, and Mac OS X
10.7 or later is required. 10.7 or later is required.
@history[#:added "1.9" @history[#:added "1.9"
#:changed "1.18" @elem{Changed @method[frame% fullscreen] with @racket[#t] #:changed "1.18" @elem{Changed @method[frame% fullscreen] with @racket[#t]
to not imply @method[window<%> show] on Windows and Mac OS.}]} to not imply @method[window<%> show] on Windows and Mac OS X.}]}
@defmethod[(get-menu-bar) @defmethod[(get-menu-bar)
(or/c (is-a?/c menu-bar%) #f)]{ (or/c (is-a?/c menu-bar%) #f)]{
@ -184,7 +184,7 @@ otherwise.
@defmethod[(is-maximized?) @defmethod[(is-maximized?)
boolean?]{ boolean?]{
On Windows and Mac OS, returns @racket[#t] if the frame is On Windows and Mac OS X, returns @racket[#t] if the frame is
maximized, @racket[#f] otherwise. On Unix, the result is always maximized, @racket[#f] otherwise. On Unix, the result is always
@racket[#f]. @racket[#f].
@ -194,7 +194,7 @@ maximized, @racket[#f] otherwise. On Unix, the result is always
void?]{ void?]{
@methspec{ @methspec{
Maximizes or restores the frame on Windows and Mac OS; the Maximizes or restores the frame on Windows and Mac OS X; the
frame's show state is not affected. On Windows, an iconized frame frame's show state is not affected. On Windows, an iconized frame
cannot be maximized or restored. cannot be maximized or restored.
@ -216,7 +216,7 @@ If @racket[maximize?] is @racket[#f], the window is restored, otherwise
void?])]{ void?])]{
Gets or sets the frame's modification state as reflected to the user. Gets or sets the frame's modification state as reflected to the user.
On Mac OS, the modification state is reflected as a dot in the On Mac OS X, the modification state is reflected as a dot in the
frame's close button. On Windows and Unix, the modification state is frame's close button. On Windows and Unix, the modification state is
reflected by an asterisk at the end of the frame's displayed title. reflected by an asterisk at the end of the frame's displayed title.
@ -261,7 +261,7 @@ Returns the result of
@defmethod[(on-toolbar-button-click) @defmethod[(on-toolbar-button-click)
void?]{ void?]{
On Mac OS, called when the user clicks the toolbar button on a On Mac OS X, called when the user clicks the toolbar button on a
frame created with the @indexed-racket['toolbar-button] style. frame created with the @indexed-racket['toolbar-button] style.
} }

14
gui-doc/scribblings/gui/global-draw-funcs.scrbl
View File

@ -19,11 +19,11 @@ other actions depend on updating the display.}
Returns the number of pixels that correspond to one drawing unit on a Returns the number of pixels that correspond to one drawing unit on a
monitor. The result is normally @racket[1.0], but it is @racket[2.0] monitor. The result is normally @racket[1.0], but it is @racket[2.0]
on Mac OS in Retina display mode, and on Windows or Unix it can be a value on Mac OS X in Retina display mode, and on Windows or Unix it can be a value
such as @racket[1.25], @racket[1.5], or @racket[2.0] when the operating-system such as @racket[1.25], @racket[1.5], or @racket[2.0] when the operating-system
scale for text is changed. See also @secref["display-resolution"]. scale for text is changed. See also @secref["display-resolution"].
On Mac OS or Unix, the result can change at any time. See also On Mac OS X or Unix, the result can change at any time. See also
@xmethod[top-level-window<%> display-changed]. @xmethod[top-level-window<%> display-changed].
If @racket[monitor] is not less than the current number of available If @racket[monitor] is not less than the current number of available
@ -36,7 +36,7 @@ If @racket[monitor] is not less than the current number of available
@defproc[(get-display-count) exact-positive-integer?]{ @defproc[(get-display-count) exact-positive-integer?]{
Returns the number of monitors currently active. Returns the number of monitors currently active.
On Windows and Mac OS, the result can change at any time. On Windows and Mac OS X, the result can change at any time.
See also @xmethod[top-level-window<%> display-changed].} See also @xmethod[top-level-window<%> display-changed].}
@ -59,7 +59,7 @@ Returns the depth of the main display (a value of 1 denotes a monochrome display
When the optional argument is @racket[#f] (the default), this function When the optional argument is @racket[#f] (the default), this function
returns the offset of @racket[monitor]'s origin from the returns the offset of @racket[monitor]'s origin from the
top-left of the physical monitor. For @racket[monitor] @racket[0], on Unix and Windows, the result is top-left of the physical monitor. For @racket[monitor] @racket[0], on Unix and Windows, the result is
always @racket[0] and @racket[0]; on Mac OS, the result is always @racket[0] and @racket[0]; on Mac OS X, the result is
@racket[0] and the height of the menu bar. To position a frame @racket[0] and the height of the menu bar. To position a frame
at a given @racket[monitor]'s top-left corner, use the negated results from at a given @racket[monitor]'s top-left corner, use the negated results from
@racket[get-display-left-top-inset] as the frame's position. @racket[get-display-left-top-inset] as the frame's position.
@ -67,7 +67,7 @@ When the optional argument is @racket[#f] (the default), this function
When the optional @racket[avoid-bars?] argument is true, for @racket[monitor] When the optional @racket[avoid-bars?] argument is true, for @racket[monitor]
@racket[0], @racket[get-display-left-top-inset] function returns the @racket[0], @racket[get-display-left-top-inset] function returns the
amount space at the left and top of the monitor that is occupied by amount space at the left and top of the monitor that is occupied by
the task bar (Windows) or menu bar and dock (Mac OS). On Unix, for the task bar (Windows) or menu bar and dock (Mac OS X). On Unix, for
monitor @racket[0], the result is always @racket[0] and @racket[0]. monitor @racket[0], the result is always @racket[0] and @racket[0].
For monitors other than @racket[0], @racket[avoid-bars?] has no effect. For monitors other than @racket[0], @racket[avoid-bars?] has no effect.
@ -89,10 +89,10 @@ See also @secref["display-resolution"].}
@index["screen resolution"]{Gets} the physical size of the specified @racket[monitor] in @index["screen resolution"]{Gets} the physical size of the specified @racket[monitor] in
pixels. On Windows, this size does not include the task bar by pixels. On Windows, this size does not include the task bar by
default. On Mac OS, this size does not include the menu bar or default. On Mac OS X, this size does not include the menu bar or
dock area by default. dock area by default.
On Windows and Mac OS, if the optional argument is true and @racket[monitor] is @racket[0], then On Windows and Mac OS X, if the optional argument is true and @racket[monitor] is @racket[0], then
the task bar, menu bar, and dock area are included in the result. the task bar, menu bar, and dock area are included in the result.
If @racket[monitor] is not less than the current number of available If @racket[monitor] is not less than the current number of available

4
gui-doc/scribblings/gui/grow-box-spacer-pane-class.scrbl
View File

@ -5,10 +5,10 @@
A @racket[grow-box-spacer-pane%] object is intended for use as a A @racket[grow-box-spacer-pane%] object is intended for use as a
lightweight spacer in the bottom-right corner of a frame, rather than lightweight spacer in the bottom-right corner of a frame, rather than
as a container. On older version of Mac OS, a as a container. On older version of Mac OS X, a
@racket[grow-box-spacer-pane%] has the same width and height as the @racket[grow-box-spacer-pane%] has the same width and height as the
grow box that is inset into the bottom-right corner of a frame. On grow box that is inset into the bottom-right corner of a frame. On
Windows, Unix, and recent Mac OS, a @racket[grow-box-spacer-pane%] has zero width and Windows, Unix, and recent Mac OS X, a @racket[grow-box-spacer-pane%] has zero width and
height. Unlike all other container types, a height. Unlike all other container types, a
@racket[grow-box-spacer-pane%] is unstretchable by default. @racket[grow-box-spacer-pane%] is unstretchable by default.

22
gui-doc/scribblings/gui/key-event-class.scrbl
View File

@ -46,7 +46,7 @@ get-key-release-code], is initialized to @racket['press].
@defmethod[(get-alt-down) @defmethod[(get-alt-down)
boolean?]{ boolean?]{
Returns @racket[#t] if the Option (Mac OS) key was down for Returns @racket[#t] if the Option (Mac OS X) key was down for
the event. When the Alt key is pressed in Windows, it is reported as the event. When the Alt key is pressed in Windows, it is reported as
a Meta press (see a Meta press (see
@method[key-event% get-meta-down]). @method[key-event% get-meta-down]).
@ -63,7 +63,7 @@ Returns @racket[#t] if the Caps Lock key was on for the event.
boolean?]{ boolean?]{
Returns @racket[#t] if the Control key was down for the event. Returns @racket[#t] if the Control key was down for the event.
On Mac OS, if a Control-key press is combined with a mouse button On Mac OS X, if a Control-key press is combined with a mouse button
click, the event is reported as a right-button click and click, the event is reported as a right-button click and
@method[key-event% get-control-down] for the event reports @racket[#f]. @method[key-event% get-control-down] for the event reports @racket[#f].
@ -177,7 +177,7 @@ The special key symbols attempt to capture useful keys that have no
@item{@racket[#\return] --- the Enter or Return key (on all @item{@racket[#\return] --- the Enter or Return key (on all
platforms), but not necessarily the Enter key near the numpad platforms), but not necessarily the Enter key near the numpad
(which is reported as @racket['numpad-enter] Unix and Mac OS)} (which is reported as @racket['numpad-enter] Unix and Mac OS X)}
@item{@racket[#\tab] --- the tab key} @item{@racket[#\tab] --- the tab key}
@ -198,7 +198,7 @@ A @racket['wheel-up], @racket['wheel-down], @racket['wheel-left], or
On Windows, when the Control key is pressed without Alt, the key On Windows, when the Control key is pressed without Alt, the key
code for ASCII characters is downcased, roughly cancelling the effect code for ASCII characters is downcased, roughly cancelling the effect
of the Shift key. On Mac OS, the key code is computed without of the Shift key. On Mac OS X, the key code is computed without
Caps Lock effects when the Control or Command key is pressed; in the Caps Lock effects when the Control or Command key is pressed; in the
case of Control, Caps Lock is used normally if special handling is case of Control, Caps Lock is used normally if special handling is
disabled for the Control key via @racket[special-control-key]. On disabled for the Control key via @racket[special-control-key]. On
@ -225,7 +225,8 @@ Gets the virtual key code for a key-release event; the result is
@defmethod[(get-meta-down) @defmethod[(get-meta-down)
boolean?]{ boolean?]{
Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS) key was down for the event. Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS
X) key was down for the event.
} }
@ -284,7 +285,8 @@ Since keyboard mappings vary, it is sometimes useful in key mappings
The @method[key-event% get-other-altgr-key-code] method provides the The @method[key-event% get-other-altgr-key-code] method provides the
same information with respect to the AltGr key (i.e., Alt combined same information with respect to the AltGr key (i.e., Alt combined
with Control) on Windows and Unix, or the Option key on Mac OS. The @method[key-event% get-other-shift-altgr-key-code] method with Control) on Windows and Unix, or the Option key on Mac OS
X. The @method[key-event% get-other-shift-altgr-key-code] method
reports a mapping for in tha case that both Shift and AltGr/Option reports a mapping for in tha case that both Shift and AltGr/Option
were different from the actual event. were different from the actual event.
@ -301,7 +303,7 @@ keys would not normally produce further alternatives.)
Alternate mappings are not available for all events. On Windows, Alternate mappings are not available for all events. On Windows,
alternate mappings are reported when they produce ASCII letters, alternate mappings are reported when they produce ASCII letters,
ASCII digits, and ASCII symbols. On Mac OS and Unix, alternate ASCII digits, and ASCII symbols. On Mac OS X and Unix, alternate
mappings are usually available. mappings are usually available.
} }
@ -332,7 +334,7 @@ Returns the y-position of the mouse at the time of the event in the
@defmethod[(set-alt-down [down? any/c]) @defmethod[(set-alt-down [down? any/c])
void?]{ void?]{
Sets whether the Option (Mac OS) key was down for the event. When Sets whether the Option (Mac OS X) key was down for the event. When
the Alt key is pressed in Windows, it is reported as a Meta press the Alt key is pressed in Windows, it is reported as a Meta press
(see @method[key-event% set-meta-down]). (see @method[key-event% set-meta-down]).
@ -350,7 +352,7 @@ Sets whether the Caps Lock key was on for the event.
Sets whether the Control key was down for the event. Sets whether the Control key was down for the event.
On Mac OS, if a control-key press is combined with a mouse button On Mac OS X, if a control-key press is combined with a mouse button
click, the event is reported as a right-button click and click, the event is reported as a right-button click and
@method[key-event% get-control-down] for the event reports @method[key-event% get-control-down] for the event reports
@racket[#f]. @racket[#f].
@ -386,7 +388,7 @@ Sets the virtual key code for a release event, either a character or
@defmethod[(set-meta-down [down? any/c]) @defmethod[(set-meta-down [down? any/c])
void?]{ void?]{
Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS X) key
was down for the event. was down for the event.
} }

12
gui-doc/scribblings/gui/keymap-class.scrbl
View File

@ -32,7 +32,7 @@ Creates an empty keymap.
} }
@defmethod[(add-function [name string?] @defmethod[(add-function [name string?]
[func (any/c (is-a?/c event%) . -> . any)]) [func (any/c (is-a?/c event%) . -> . any/c)])
void?]{ void?]{
Names a new function to handle events, called in response to Names a new function to handle events, called in response to
@ -181,12 +181,12 @@ The modifier identifiers are:
@item{@litchar{c:} --- All platforms: Control} @item{@litchar{c:} --- All platforms: Control}
@item{@litchar{a:} --- Mac OS: Option} @item{@litchar{a:} --- Mac OS X: Option}
@item{@litchar{m:} --- Windows: Alt; Unix: Meta; Mac OS: Command, when @item{@litchar{m:} --- Windows: Alt; Unix: Meta; Mac OS X: Command, when
@racket[map-command-as-meta-key] produces @racket[#t]} @racket[map-command-as-meta-key] produces @racket[#t]}
@item{@litchar{d:} --- Mac OS: Command} @item{@litchar{d:} --- Mac OS X: Command}
@item{@litchar{l:} --- All platforms: Caps Lock} @item{@litchar{l:} --- All platforms: Caps Lock}
@ -295,10 +295,10 @@ For a special keyword, the capitalization does not matter. However,
single-letter ASCII keynames are treated specially: @litchar{A} and single-letter ASCII keynames are treated specially: @litchar{A} and
@litchar{s:a} are both treated as @litchar{s:A}. However, when @litchar{s:a} are both treated as @litchar{s:A}. However, when
@litchar{c:} is included on Windows without @litchar{m:}, or when @litchar{c:} is included on Windows without @litchar{m:}, or when
@litchar{d:} is included on Mac OS, then ASCII letters are not @litchar{d:} is included on Mac OS X, then ASCII letters are not
upcased with @litchar{s:}, since the upcasing behavior of the Shift key upcased with @litchar{s:}, since the upcasing behavior of the Shift key
is cancelled by Control without Alt (on Windows) or by Command is cancelled by Control without Alt (on Windows) or by Command
(on Mac OS). (on Mac OS X).
A state can match multiple state strings mapped in a keymap (or keymap A state can match multiple state strings mapped in a keymap (or keymap
chain); when a state matches multiple state strings, a mapping is chain); when a state matches multiple state strings, a mapping is

4
gui-doc/scribblings/gui/labelled-menu-item-intf.scrbl
View File

@ -106,9 +106,9 @@ If the label contains @litchar{&} and the window is a control, the
selected (via @method[frame% on-menu-char]). When a menu has the selected (via @method[frame% on-menu-char]). When a menu has the
focus, the mnemonic characters are used for navigation without Alt. A focus, the mnemonic characters are used for navigation without Alt. A
@litchar{&&} in the label is replaced by a literal (non-navigation) @litchar{&&} in the label is replaced by a literal (non-navigation)
@litchar{&}. On Mac OS, @litchar{&}s in the label are parsed in @litchar{&}. On Mac OS X, @litchar{&}s in the label are parsed in
the same way as for Unix and Windows, but no mnemonic underline is the same way as for Unix and Windows, but no mnemonic underline is
displayed. On Mac OS, a parenthesized mnemonic character is displayed. On Mac OS X, a parenthesized mnemonic character is
removed (along with any surrounding space) before the label is removed (along with any surrounding space) before the label is
displayed, since a parenthesized mnemonic is often used for non-Roman displayed, since a parenthesized mnemonic is often used for non-Roman
languages. Finally, for historical reasons, if a label contains a tab character, then the languages. Finally, for historical reasons, if a label contains a tab character, then the

2
gui-doc/scribblings/gui/message-class.scrbl
View File

@ -29,7 +29,7 @@ Creates a string or bitmap message initially showing @racket[label].
@bitmaplabeluse[label] An @indexed-racket['app], @bitmaplabeluse[label] An @indexed-racket['app],
@indexed-racket['caution], or @indexed-racket['stop] symbol for @indexed-racket['caution], or @indexed-racket['stop] symbol for
@racket[label] indicates an icon; @racket['app] is the application @racket[label] indicates an icon; @racket['app] is the application
icon (Windows and Mac OS) or a generic ``info'' icon (X), icon (Windows and Mac OS X) or a generic ``info'' icon (X),
@racket['caution] is a caution-sign icon, and @racket['stop] is a @racket['caution] is a caution-sign icon, and @racket['stop] is a
stop-sign icon. stop-sign icon.

14
gui-doc/scribblings/gui/miscwin-funcs.scrbl
View File

@ -56,7 +56,7 @@ See @racket[begin-busy-cursor].
(lambda (s) (and (bytes? s) (lambda (s) (and (bytes? s)
(= 4 (bytes-length s)))))])]{ (= 4 (bytes-length s)))))])]{
Gets or sets the creator and type of a file in Mac OS. Gets or sets the creator and type of a file in Mac OS X.
The get operation always returns @racket[#"????"] and @racket[#"????"] for The get operation always returns @racket[#"????"] and @racket[#"????"] for
Unix or Windows. The set operation has no effect on Unix or Unix or Windows. The set operation has no effect on Unix or
@ -105,7 +105,7 @@ Returns an immutable list specifying the default prefix for menu
shortcuts. See also shortcuts. See also
@xmethod[selectable-menu-item<%> get-shortcut-prefix]. @xmethod[selectable-menu-item<%> get-shortcut-prefix].
On Windows, the default is @racket['(ctl)]. On Mac OS, the On Windows, the default is @racket['(ctl)]. On Mac OS X, the
default is @racket['(cmd)]. On Unix, the default is normally default is @racket['(cmd)]. On Unix, the default is normally
@racket['(ctl)], but the default can be changed through the @racket['(ctl)], but the default can be changed through the
@Resource{defaultMenuPrefix} low-level preference (see @Resource{defaultMenuPrefix} low-level preference (see
@ -197,7 +197,7 @@ follows:
@item{@racket['win32] (Windows)} @item{@racket['win32] (Windows)}
@item{@racket['cocoa] (Mac OS)} @item{@racket['cocoa] (Mac OS X)}
@item{@racket['gtk2] --- GTK+ version 2} @item{@racket['gtk2] --- GTK+ version 2}
@ -232,7 +232,7 @@ break is sent (via @racket[break-thread]) to the created eventspace's
(listof (or/c 'left 'middle 'right (listof (or/c 'left 'middle 'right
'shift 'control 'alt 'meta 'caps)))]{ 'shift 'control 'alt 'meta 'caps)))]{
@margin-note{On Mac OS 10.5 and earlier, mouse-button information is @margin-note{On Mac OS X 10.5 and earlier, mouse-button information is
not available, so the second result includes only symbols for modifier not available, so the second result includes only symbols for modifier
keys.} keys.}
@ -303,7 +303,7 @@ environment of the result namespace.}
Creates a bitmap that draws in a way that is the same as drawing to a Creates a bitmap that draws in a way that is the same as drawing to a
canvas in its default configuration. canvas in its default configuration.
In particular, on Mac OS when the main monitor is in Retina display In particular, on Mac OS X when the main monitor is in Retina display
mode, a drawing unit corresponds to two pixels, and the bitmap mode, a drawing unit corresponds to two pixels, and the bitmap
internally contains four times as many pixels as requested by internally contains four times as many pixels as requested by
@racket[width] and @racket[height]. On Windows, the backing scale @racket[width] and @racket[height]. On Windows, the backing scale
@ -325,7 +325,7 @@ Plays a sound file. If @racket[async?] is false, the function does not
On Windows, MCI is used to play sounds, so file formats such as On Windows, MCI is used to play sounds, so file formats such as
@filepath{.wav} and @filepath{.mp3} should be supported. @filepath{.wav} and @filepath{.mp3} should be supported.
On Mac OS, Quicktime is used to play sounds; most sound On Mac OS X, Quicktime is used to play sounds; most sound
formats (@filepath{.wav}, @filepath{.aiff}, @filepath{.mp3}) are supported in recent versions of formats (@filepath{.wav}, @filepath{.aiff}, @filepath{.mp3}) are supported in recent versions of
Quicktime. To play @filepath{.wav} files, Quicktime 3.0 (compatible Quicktime. To play @filepath{.wav} files, Quicktime 3.0 (compatible
with OS 7.5 and up) is required. with OS 7.5 and up) is required.
@ -426,7 +426,7 @@ Equivalent to @racket[(integer-in 0 1000)].}
Returns @racket[#t] on Windows---indicating that a dialog with Returns @racket[#t] on Windows---indicating that a dialog with
@onscreen{OK} and @onscreen{Cancel} buttons should place the @onscreen{OK} and @onscreen{Cancel} buttons should place the
@onscreen{OK} button on to left of the @onscreen{Cancel} button---and @onscreen{OK} button on to left of the @onscreen{Cancel} button---and
returns @racket[#f] on Mac OS and Unix.} returns @racket[#f] on Mac OS X and Unix.}
@defthing[the-clipboard (is-a?/c clipboard<%>)]{ @defthing[the-clipboard (is-a?/c clipboard<%>)]{

25
gui-doc/scribblings/gui/mouse-event-class.scrbl
View File

@ -41,8 +41,8 @@ Creates a mouse event for a particular type of event. The event types
@item{@racket['left-up] --- left mouse button released} @item{@racket['left-up] --- left mouse button released}
@item{@racket['middle-down] --- middle mouse button pressed} @item{@racket['middle-down] --- middle mouse button pressed}
@item{@racket['middle-up] --- middle mouse button released} @item{@racket['middle-up] --- middle mouse button released}
@item{@racket['right-down] --- right mouse button pressed (Mac OS: click with control key pressed)} @item{@racket['right-down] --- right mouse button pressed (Mac OS X: click with control key pressed)}
@item{@racket['right-up] --- right mouse button released (Mac OS: release with control key pressed)} @item{@racket['right-up] --- right mouse button released (Mac OS X: release with control key pressed)}
@item{@racket['motion] --- mouse moved, with or without button(s) pressed} @item{@racket['motion] --- mouse moved, with or without button(s) pressed}
] ]
@ -121,7 +121,7 @@ When the mouse button is up, an enter/leave event notifies a window
@defmethod[(get-alt-down) @defmethod[(get-alt-down)
boolean?]{ boolean?]{
Returns @racket[#t] if the Option (Mac OS) key was down for the Returns @racket[#t] if the Option (Mac OS X) key was down for the
event. When the Alt key is pressed in Windows, it is reported as a event. When the Alt key is pressed in Windows, it is reported as a
Meta press (see @method[mouse-event% get-meta-down]). Meta press (see @method[mouse-event% get-meta-down]).
@ -139,7 +139,7 @@ Returns @racket[#t] if the Caps Lock key was on for the event.
Returns @racket[#t] if the Control key was down for the event. Returns @racket[#t] if the Control key was down for the event.
On Mac OS, if a control-key press is combined with a mouse button On Mac OS X, if a control-key press is combined with a mouse button
click, the event is reported as a right-button click and click, the event is reported as a right-button click and
@method[mouse-event% get-control-down] for the event reports @method[mouse-event% get-control-down] for the event reports
@racket[#f]. @racket[#f].
@ -166,7 +166,8 @@ Returns @racket[#t] if the left mouse button was down (but not pressed) during t
@defmethod[(get-meta-down) @defmethod[(get-meta-down)
boolean?]{ boolean?]{
Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS) key was down for the event. Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS
X) key was down for the event.
} }
@ -174,7 +175,7 @@ Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS) key w
boolean?]{ boolean?]{
Returns @racket[#t] if the middle mouse button was down (but not Returns @racket[#t] if the middle mouse button was down (but not
pressed) for the event. On Mac OS, a middle-button click is pressed) for the event. On Mac OS X, a middle-button click is
impossible. impossible.
} }
@ -204,7 +205,7 @@ Returns @racket[#t] if the Mod5 (Unix) key was down for the event.
boolean?]{ boolean?]{
Returns @racket[#t] if the right mouse button was down (but not Returns @racket[#t] if the right mouse button was down (but not
pressed) for the event. On Mac OS, a control-click combination pressed) for the event. On Mac OS X, a control-click combination
is treated as a right-button click. is treated as a right-button click.
} }
@ -254,7 +255,7 @@ Returns @racket[#t] if this was a moving event (whether a button is
@defmethod[(set-alt-down [down? any/c]) @defmethod[(set-alt-down [down? any/c])
void?]{ void?]{
Sets whether the Option (Mac OS) key was down for the event. When Sets whether the Option (Mac OS X) key was down for the event. When
the Alt key is pressed in Windows, it is reported as a Meta press the Alt key is pressed in Windows, it is reported as a Meta press
(see @method[mouse-event% set-meta-down]). (see @method[mouse-event% set-meta-down]).
@ -272,7 +273,7 @@ Sets whether the Caps Lock key was on for the event.
Sets whether the Control key was down for the event. Sets whether the Control key was down for the event.
On Mac OS, if a control-key press is combined with a mouse button On Mac OS X, if a control-key press is combined with a mouse button
click, the event is reported as a right-button click and click, the event is reported as a right-button click and
@method[mouse-event% get-control-down] for the event reports @method[mouse-event% get-control-down] for the event reports
@racket[#f]. @racket[#f].
@ -300,7 +301,7 @@ the event.
@defmethod[(set-meta-down [down? any/c]) @defmethod[(set-meta-down [down? any/c])
void?]{ void?]{
Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS X) key
was down for the event. was down for the event.
} }
@ -309,7 +310,7 @@ Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key
void?]{ void?]{
Sets whether the middle mouse button was down (but not pressed) for Sets whether the middle mouse button was down (but not pressed) for
the event. On Mac OS, a middle-button click is impossible. the event. On Mac OS X, a middle-button click is impossible.
} }
@ -338,7 +339,7 @@ Sets whether the Mod5 (Unix) key was down for the event.
void?]{ void?]{
Sets whether the right mouse button was down (but not pressed) for the Sets whether the right mouse button was down (but not pressed) for the
event. On Mac OS, a control-click combination by the user is event. On Mac OS X, a control-click combination by the user is
treated as a right-button click. treated as a right-button click.
} }

2
gui-doc/scribblings/gui/pasteboard-class.scrbl
View File

@ -553,7 +553,7 @@ Pastes.
@methspec{ @methspec{
Called to paste the current contents of the X11 selection on Unix (or Called to paste the current contents of the X11 selection on Unix (or
the clipboard on Windows and Mac OS) into the editor. This the clipboard on Windows and Mac OS X) into the editor. This
method is provided so that it can be overridden by subclasses. Do method is provided so that it can be overridden by subclasses. Do
not call this method directly; instead, call @method[editor<%> not call this method directly; instead, call @method[editor<%>
paste-x-selection]. paste-x-selection].

4
gui-doc/scribblings/gui/selectable-menu-item-intf.scrbl
View File

@ -55,11 +55,11 @@ Returns a list of symbols that indicates the keyboard prefix used for the menu
@itemize[ @itemize[
@item{@racket['alt] --- Meta (Windows and X only)} @item{@racket['alt] --- Meta (Windows and X only)}
@item{@racket['cmd] --- Command (Mac OS only)} @item{@racket['cmd] --- Command (Mac OS X only)}
@item{@racket['meta] --- Meta (Unix only)} @item{@racket['meta] --- Meta (Unix only)}
@item{@racket['ctl] --- Control} @item{@racket['ctl] --- Control}
@item{@racket['shift] --- Shift} @item{@racket['shift] --- Shift}
@item{@racket['option] --- Option (Mac OS only)} @item{@racket['option] --- Option (Mac OS X only)}
] ]
On Unix, at most one of @racket['alt] and @racket['meta] can be On Unix, at most one of @racket['alt] and @racket['meta] can be

2
gui-doc/scribblings/gui/snip-example.scrbl
View File

@ -119,5 +119,5 @@ directory.
This is the @filepath{wxme-circle-snip.rkt} file: This is the @filepath{wxme-circle-snip.rkt} file:
@(put-code wxme-circle-snip.rkt) @(put-code wxme-circle-snip.rkt))

19
gui-doc/scribblings/gui/system-menu-funcs.scrbl
View File

@ -6,14 +6,14 @@
@defproc[(current-eventspace-has-standard-menus?) @defproc[(current-eventspace-has-standard-menus?)
boolean?]{ boolean?]{
Returns @racket[#t] for Mac OS when the current eventspace is the Returns @racket[#t] for Mac OS X when the current eventspace is the
initial one, since that eventspace is the target for the standard initial one, since that eventspace is the target for the standard
application menus. For any other system or eventspace, the result is application menus. For any other system or eventspace, the result is
@racket[#f]. @racket[#f].
This procedure is intended for use in deciding whether to include a This procedure is intended for use in deciding whether to include a
@onscreen{Quit}, @onscreen{About}, and @onscreen{Preferences} menu @onscreen{Quit}, @onscreen{About}, and @onscreen{Preferences} menu
item in a frame's menu. On Mac OS, the application item in a frame's menu. On Mac OS X, the application
@onscreen{Quit} menu triggers a call to a frame's @onscreen{Quit} menu triggers a call to a frame's
@method[top-level-window<%> on-exit] method, the @onscreen{About} menu item is controlled by @method[top-level-window<%> on-exit] method, the @onscreen{About} menu item is controlled by
@racket[application-about-handler], and the @racket[application-about-handler], and the
@ -24,7 +24,7 @@ This procedure is intended for use in deciding whether to include a
@defproc[(current-eventspace-has-menu-root?) @defproc[(current-eventspace-has-menu-root?)
boolean?]{ boolean?]{
Returns @racket[#t] for Mac OS when the current eventspace is the Returns @racket[#t] for Mac OS X when the current eventspace is the
initial one, since that eventspace can supply a menu bar to be active initial one, since that eventspace can supply a menu bar to be active
when no frame is visible. For any other system or eventspace, the when no frame is visible. For any other system or eventspace, the
result is @racket[#f]. result is @racket[#f].
@ -41,7 +41,8 @@ This procedure is intended for use in deciding whether to create a
When the current eventspace is the initial eventspace, this When the current eventspace is the initial eventspace, this
procedure retrieves or installs a thunk that is called when the procedure retrieves or installs a thunk that is called when the
user selects the application @onscreen{About} menu item on Mac OS. The thunk is always called in the initial eventspace's user selects the application @onscreen{About} menu item on Mac OS
X. The thunk is always called in the initial eventspace's
handler thread (as a callback). handler thread (as a callback).
The default handler displays a generic Racket dialog. The default handler displays a generic Racket dialog.
@ -58,7 +59,7 @@ or has no effect (when called with a handler).
[(application-file-handler [handler-proc (path? . -> . any)]) [(application-file-handler [handler-proc (path? . -> . any)])
void?])]{ void?])]{
When the current eventspace is the initial eventspace, this procedure When the current eventspace is the initial eventspace, this procedure
retrieves or installs a procedure that is called on Mac OS retrieves or installs a procedure that is called on Mac OS X
and Windows when the application is running and user double-clicks an and Windows when the application is running and user double-clicks an
application-handled file or drags a file onto the application's application-handled file or drags a file onto the application's
icon. The procedure is always called in the initial eventspace's icon. The procedure is always called in the initial eventspace's
@ -76,7 +77,7 @@ On Windows, when the application is @italic{not} running and user double-clicks
the filename is provided as a command-line argument to the the filename is provided as a command-line argument to the
application. application.
On Mac OS, if an application is started @emph{without} files, then On Mac OS X, if an application is started @emph{without} files, then
the @racket[application-start-empty-handler] procedure is called. the @racket[application-start-empty-handler] procedure is called.
If the current eventspace is not the initial eventspace, this If the current eventspace is not the initial eventspace, this
@ -91,7 +92,7 @@ or has no effect (when called with a handler).
void?])]{ void?])]{
When the current eventspace is the initial eventspace, this procedure When the current eventspace is the initial eventspace, this procedure
retrieves or installs a thunk that is called when the user selects retrieves or installs a thunk that is called when the user selects
the application @onscreen{Preferences} menu item on Mac OS. The the application @onscreen{Preferences} menu item on Mac OS X. The
thunk is always called in the initial eventspace's handler thread (as thunk is always called in the initial eventspace's handler thread (as
a callback). If the handler is set to @racket[#f], the a callback). If the handler is set to @racket[#f], the
@onscreen{Preferences} item is disabled. @onscreen{Preferences} item is disabled.
@ -110,7 +111,7 @@ or has no effect (when called with a handler).
When the current eventspace is the initial eventspace, this procedure When the current eventspace is the initial eventspace, this procedure
retrieves or installs a thunk that is called when the user requests retrieves or installs a thunk that is called when the user requests
that the application quit (e.g., through the @onscreen{Quit} menu that the application quit (e.g., through the @onscreen{Quit} menu
item on Mac OS, or when shutting down the machine in Windows). The item on Mac OS X, or when shutting down the machine in Windows). The
thunk is always called in the initial eventspace's handler thread (as thunk is always called in the initial eventspace's handler thread (as
a callback). If the result of the thunk is @racket[#f], then the a callback). If the result of the thunk is @racket[#f], then the
operating system is explicitly notified that the application does not operating system is explicitly notified that the application does not
@ -138,7 +139,7 @@ or has no effect (when called with a handler).
void?])]{ void?])]{
When the current eventspace is the initial eventspace, this procedure When the current eventspace is the initial eventspace, this procedure
retrieves or installs a thunk that is called when the user starts retrieves or installs a thunk that is called when the user starts
the application on Mac OS without supplying any initial files (e.g., the application on Mac OS X without supplying any initial files (e.g.,
by double-clicking the application icon instead of double-clicking by double-clicking the application icon instead of double-clicking
files that are handled by the application). files that are handled by the application).

10
gui-doc/scribblings/gui/text-class.scrbl
View File

@ -479,7 +479,7 @@ Pastes into the @techlink{position} @racket[start].
@methspec{ @methspec{
Called to paste the current contents of the X11 selection on Unix (or the Called to paste the current contents of the X11 selection on Unix (or the
clipboard on Windows or Mac OS) into the editor. This method is clipboard on Windows or Mac OS X) into the editor. This method is
provided so that it can be overridden by subclasses. Do not call provided so that it can be overridden by subclasses. Do not call
this method directly; instead, call @method[text% paste-x-selection]. this method directly; instead, call @method[text% paste-x-selection].
@ -637,7 +637,7 @@ can be any of the following:
} }
@defmethod[(find-string [str non-empty-string?] @defmethod[(find-string [str string?]
[direction (or/c 'forward 'backward) 'forward] [direction (or/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? 'start) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? 'eof) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
@ -668,7 +668,7 @@ If @racket[case-sensitive?] is @racket[#f], then an uppercase and lowercase
} }
@defmethod[(find-string-embedded [str non-empty-string?] @defmethod[(find-string-embedded [str string?]
[direction (or/c 'forward 'backward) 'forward] [direction (or/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? 'start) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? 'eof) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
@ -690,7 +690,7 @@ If @racket[case-sensitive?] is @racket[#f], then an uppercase and lowercase
search result position. search result position.
} }
@defmethod[(find-string-all [str non-empty-string?] @defmethod[(find-string-all [str string?]
[direction (or/c 'forward 'backward) 'forward] [direction (or/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? 'start) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? 'eof) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
@ -704,7 +704,7 @@ Finds all occurrences of a string using @method[text% find-string]. If
} }
@defmethod[(find-string-embedded-all [str non-empty-string?] @defmethod[(find-string-embedded-all [str string?]
[direction (or/c 'forward 'backward) 'forward] [direction (or/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? 'start) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? 'eof) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]

8
gui-doc/scribblings/gui/top-level-window-intf.scrbl
View File

@ -125,7 +125,7 @@ Called when a window is @defterm{activated} or
@defterm{deactivated}. A top-level window is activated when the @defterm{deactivated}. A top-level window is activated when the
keyboard focus moves from outside the window to the window or one of keyboard focus moves from outside the window to the window or one of
its children. It is deactivated when the focus moves back out of the its children. It is deactivated when the focus moves back out of the
window. On Mac OS, a child of a floating frames can have the window. On Mac OS X, a child of a floating frames can have the
focus instead of a child of the active non-floating frame; in other focus instead of a child of the active non-floating frame; in other
words, floating frames act as an extension of the active non-frame words, floating frames act as an extension of the active non-frame
for keyboard focus. for keyboard focus.
@ -156,7 +156,7 @@ Called by the default application quit handler (as determined by the
@racket[application-quit-handler] parameter) when the operating @racket[application-quit-handler] parameter) when the operating
system requests that the application shut down (e.g., when the system requests that the application shut down (e.g., when the
@onscreen{Quit} menu item is selected in the main application menu @onscreen{Quit} menu item is selected in the main application menu
on Mac OS). In that case, this method is called for the most on Mac OS X). In that case, this method is called for the most
recently active top-level window in the initial eventspace, but only recently active top-level window in the initial eventspace, but only
if the window's @method[top-level-window<%> can-exit?] method first if the window's @method[top-level-window<%> can-exit?] method first
returns true. returns true.
@ -249,7 +249,7 @@ If the window that currently owns the focus specifically handles the
@item{@racket[text-field%], @racket['single] style --- arrow key @item{@racket[text-field%], @racket['single] style --- arrow key
events and alphanumeric key events when the Meta (Unix) or Alt events and alphanumeric key events when the Meta (Unix) or Alt
(Windows) key is not pressed (and all alphanumeric events on (Windows) key is not pressed (and all alphanumeric events on
Mac OS)} Mac OS X)}
@item{@racket[text-field%], @racket['multiple] style --- all @item{@racket[text-field%], @racket['multiple] style --- all
keyboard events, except alphanumeric key events when the Meta (Unix) or keyboard events, except alphanumeric key events when the Meta (Unix) or
@ -348,7 +348,7 @@ The icon is used in a platform-specific way:
top-left) and in the task bar, and the large icon is used for top-left) and in the task bar, and the large icon is used for
the Alt-Tab task switcher.} the Alt-Tab task switcher.}
@item{Mac OS --- both icons are ignored.} @item{Mac OS X --- both icons are ignored.}
@item{Unix --- many window managers use the small icon in the same way @item{Unix --- many window managers use the small icon in the same way
as Windows, and others use the small icon when iconifying the as Windows, and others use the small icon when iconifying the

4
gui-doc/scribblings/gui/win-overview.scrbl
View File

@ -938,7 +938,7 @@ Whenever the system dispatches an event, the call to the handler is
any captured continuation includes the invocation of the @tech{event any captured continuation includes the invocation of the @tech{event
dispatch handler}. dispatch handler}.
For example, if a button callback raises an exception, then the abort For example, if a button callback raises an exception, than the abort
performed by the default exception handler returns to the event-dispatch performed by the default exception handler returns to the event-dispatch
point, rather than terminating the program or escaping past an enclosing point, rather than terminating the program or escaping past an enclosing
@racket[(yield)]. If @racket[with-handlers] wraps a @racket[(yield)] that @racket[(yield)]. If @racket[with-handlers] wraps a @racket[(yield)] that
@ -1006,7 +1006,7 @@ sequence.
@section[#:tag "display-resolution"]{Screen Resolution and Text Scaling} @section[#:tag "display-resolution"]{Screen Resolution and Text Scaling}
On Mac OS, screen sizes are described to users in terms of drawing On Mac OS X, screen sizes are described to users in terms of drawing
units. A Retina display provides two pixels per drawing unit, while units. A Retina display provides two pixels per drawing unit, while
drawing units are used consistently for window sizes, child window drawing units are used consistently for window sizes, child window
positions, and canvas drawing. A ``point'' for font sizing is positions, and canvas drawing. A ``point'' for font sizing is

8
gui-doc/scribblings/gui/window-intf.scrbl
View File

@ -37,7 +37,7 @@ All @racket[window<%>] classes accept the following named instantiation
@index["global coordinates"]{Converts} local window coordinates to @index["global coordinates"]{Converts} local window coordinates to
screen coordinates. screen coordinates.
On Mac OS, the screen coordinates start with @math{(0, 0)} at the On Mac OS X, the screen coordinates start with @math{(0, 0)} at the
upper left of the menu bar. In contrast, @xmethod[top-level-window<%> upper left of the menu bar. In contrast, @xmethod[top-level-window<%>
move] considers @math{(0, 0)} to be below the menu bar. See also move] considers @math{(0, 0)} to be below the menu bar. See also
@racket[get-display-left-top-inset]. @racket[get-display-left-top-inset].
@ -93,7 +93,7 @@ on the platform:
@item{Windows: @tt{HWND}} @item{Windows: @tt{HWND}}
@item{Mac OS: @tt{NSView}} @item{Mac OS X: @tt{NSView}}
@item{Unix: @tt{GtkWidget}} @item{Unix: @tt{GtkWidget}}
@ -139,7 +139,7 @@ platform:
@item{Windows: @tt{HWND}} @item{Windows: @tt{HWND}}
@item{Mac OS: @tt{NSWindow} for a @racket[top-level-window<%>] object, @item{Mac OS X: @tt{NSWindow} for a @racket[top-level-window<%>] object,
@tt{NSView} for other windows} @tt{NSView} for other windows}
@item{Unix: @tt{GtkWidget}} @item{Unix: @tt{GtkWidget}}
@ -312,7 +312,7 @@ Indicates whether the window is currently shown or not. The result is
protocol.) Drag-and-drop must first be enabled for the window with protocol.) Drag-and-drop must first be enabled for the window with
@method[window<%> accept-drop-files]. @method[window<%> accept-drop-files].
On Mac OS, when the application is running and user On Mac OS X, when the application is running and user
double-clicks an application-handled file or drags a file onto the double-clicks an application-handled file or drags a file onto the
application's icon, the main thread's application file handler is application's icon, the main thread's application file handler is
called (see called (see

2
gui-doc/scribblings/gui/wxme.scrbl
View File

@ -495,7 +495,7 @@ Racket boxes.}
A text-mode reader for Racket boxes.}] A text-mode reader for Racket boxes.}]
@defclass[scheme-editor% editor% (readable<%>)]{ @defclass[racket-editor% editor% (readable<%>)]{
Instantiated for DrRacket Racket boxes in a @tech{WXME} stream for text Instantiated for DrRacket Racket boxes in a @tech{WXME} stream for text
mode. mode.

86
gui-lib/framework/gui-utils.rkt
View File

@ -230,8 +230,7 @@
(λ () (thunk)) (λ () (thunk))
(λ () (cursor-off))))]))) (λ () (cursor-off))))])))
(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t] (define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t])
#:dialog-mixin [dialog-mixin values])
(define key-closed #f) (define key-closed #f)
(define (unsaved-warning-mixin %) (define (unsaved-warning-mixin %)
(class % (class %
@ -266,41 +265,39 @@
'(default=2 caution)) '(default=2 caution))
2 2
#:dialog-mixin (if (equal? (system-type) 'macosx) #:dialog-mixin (if (equal? (system-type) 'macosx)
(compose unsaved-warning-mixin dialog-mixin) unsaved-warning-mixin
dialog-mixin))) values)))
(or key-closed (or key-closed
(case mb-res (case mb-res
[(1) 'save] [(1) 'save]
[(2) 'cancel] [(2) 'cancel]
[(3) 'continue]))) [(3) 'continue])))
(define (get-choice message (define get-choice
true-choice (lambda (message
false-choice true-choice
[title (string-constant warning)] false-choice
[default-result 'disallow-close] (title (string-constant warning))
[parent #f] (default-result 'disallow-close)
[style 'app] (parent #f)
[checkbox-proc #f] (style 'app)
[checkbox-label (string-constant dont-ask-again)] (checkbox-proc #f)
#:dialog-mixin [dialog-mixin values]) (checkbox-label (string-constant dont-ask-again)))
(let* ([check? (and checkbox-proc (checkbox-proc))] (let* ([check? (and checkbox-proc (checkbox-proc))]
[style (if (eq? style 'app) `(default=1) `(default=1 ,style))] [style (if (eq? style 'app) `(default=1) `(default=1 ,style))]
[style (if (eq? 'disallow-close default-result) [style (if (eq? 'disallow-close default-result)
(cons 'disallow-close style) style)] (cons 'disallow-close style) style)]
[style (if check? (cons 'checked style) style)] [style (if check? (cons 'checked style) style)]
[return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))]) [return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
(if checkbox-proc (if checkbox-proc
(let-values ([(mb-res checked) (let-values ([(mb-res checked)
(message+check-box/custom title message checkbox-label (message+check-box/custom title message checkbox-label
true-choice false-choice #f true-choice false-choice #f
parent style default-result parent style default-result)])
#:dialog-mixin dialog-mixin)]) (checkbox-proc checked)
(checkbox-proc checked) (return mb-res))
(return mb-res)) (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
#:dialog-mixin dialog-mixin)))))
;; manual renaming ;; manual renaming
(define gui-utils:trim-string trim-string) (define gui-utils:trim-string trim-string)
@ -386,7 +383,7 @@
(cancel-label (string-constant cancel)) (cancel-label (string-constant cancel))
(confirm-style '(border)))) (confirm-style '(border))))
@{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 Mac OS 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 is on the right (or bottom) and under Windows, the canceling action is on
the right (or bottom). the right (or bottom).
The buttons are also sized to be the same width. The buttons are also sized to be the same width.
@ -493,14 +490,12 @@
(or/c false/c (or/c false/c
(is-a?/c frame%) (is-a?/c frame%)
(is-a?/c dialog%)) (is-a?/c dialog%))
boolean? boolean?)
#:dialog-mixin (make-mixin-contract dialog%))
(symbols 'continue 'save 'cancel)) (symbols 'continue 'save 'cancel))
((filename action) ((filename action)
((can-save-now? #f) ((can-save-now? #f)
(parent #f) (parent #f)
(cancel? #t) (cancel? #t)))
(dialog-mixin values)))
@{This displays a dialog that warns the user of a unsaved file. @{This displays a dialog that warns the user of a unsaved file.
@ -516,10 +511,6 @@
in the dialog and the result may be @racket['cancel]. If it in the dialog and the result may be @racket['cancel]. If it
is @racket[#f], then there is no cancel button, and @racket['cancel] is @racket[#f], then there is no cancel button, and @racket['cancel]
will not be the result of the function. will not be the result of the function.
The @racket[dialog-mixin] argument is passed to @racket[message-box/custom].
@history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
}) })
@ -534,8 +525,7 @@
(symbols 'app 'caution 'stop) (symbols 'app 'caution 'stop)
(or/c false/c (case-> (boolean? . -> . void?) (or/c false/c (case-> (boolean? . -> . void?)
(-> boolean?))) (-> boolean?)))
string? string?)
#:dialog-mixin (make-mixin-contract dialog%))
any/c) any/c)
((message true-choice false-choice) ((message true-choice false-choice)
((title (string-constant warning)) ((title (string-constant warning))
@ -543,8 +533,7 @@
(parent #f) (parent #f)
(style 'app) (style 'app)
(checkbox-proc #f) (checkbox-proc #f)
(checkbox-label (string-constant dont-ask-again)) (checkbox-label (string-constant dont-ask-again))))
(dialog-mixin values)))
@{Opens a dialog that presents a binary choice to the user. The user is @{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 forced to choose between these two options, ie cancelling or closing the
@ -576,14 +565,7 @@
(defaults to the @racket[dont-ask-again] string constant), and that (defaults to the @racket[dont-ask-again] string constant), and that
checkbox value will be sent to the @racket[checkbox-proc] when the dialog checkbox value will be sent to the @racket[checkbox-proc] when the dialog
is closed. Note that the dialog will always pop-up --- it is the is closed. Note that the dialog will always pop-up --- it is the
caller's responsibility to avoid the dialog if not needed. caller's responsibility to avoid the dialog if not needed.})
The @racket[dialog-mixin] argument is passed to @racket[message-box/custom]
or @racket[message+check-box/custom].
@history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
})
(proc-doc/names (proc-doc/names
gui-utils:get-clicked-clickback-delta gui-utils:get-clicked-clickback-delta

24
gui-lib/framework/main.rkt
View File

@ -193,38 +193,22 @@
(proc-doc/names (proc-doc/names
number-snip:make-repeating-decimal-snip number-snip:make-repeating-decimal-snip
(-> real? boolean? number-snip:is-number-snip?) (real? boolean? . -> . (is-a?/c snip%))
(num show-prefix?) (num show-prefix?)
@{Makes a @tech{number snip} that shows the decimal expansion for @racket[number]. @{Makes a number snip that shows the decimal expansion for @racket[number].
The boolean indicates if a @litchar{#e} prefix appears on the number. The boolean indicates if a @litchar{#e} prefix appears on the number.
See also @racket[number-snip:make-fraction-snip].}) See also @racket[number-snip:make-fraction-snip].})
(proc-doc/names (proc-doc/names
number-snip:make-fraction-snip number-snip:make-fraction-snip
(-> real? boolean? number-snip:is-number-snip?) (real? boolean? . -> . (is-a?/c snip%))
(num show-prefix-in-decimal-view?) (num show-prefix-in-decimal-view?)
@{Makes a @tech{number snip} that shows a fractional view of @racket[number]. @{Makes a number snip that shows a fractional view of @racket[number].
The boolean indicates if a @litchar{#e} prefix appears on the number, when The boolean indicates if a @litchar{#e} prefix appears on the number, when
shown in the decimal state. shown in the decimal state.
See also @racket[number-snip:make-repeating-decimal-snip].}) See also @racket[number-snip:make-repeating-decimal-snip].})
(proc-doc/names
number-snip:is-number-snip?
(-> any/c boolean?)
(v)
@{Determines if @racket[v] is a @deftech{number snip}, i.e., created
by @racket[number-snip:make-fraction-snip]
or @racket[number-snip:make-repeating-decimal-snip].
All values that answer @racket[#t] to this predicate are also @racket[snip%]s.})
(proc-doc/names
number-snip:get-number
(-> number-snip:is-number-snip? real?)
(ns)
@{Returns the number that this @tech{number snip} displays.})
(thing-doc (thing-doc
comment-box:snipclass comment-box:snipclass

577
gui-lib/framework/preferences.rkt
View File

@ -21,17 +21,14 @@ the state transitions / contracts are:
set-un/marshall(true, false, true) -> (true, true, true) set-un/marshall(true, false, true) -> (true, true, true)
.. otherwise error .. otherwise error
for all syms: for all syms:
prefs-snapshot(_, _, _) -> (_, _, false) prefs-snapshot(_, _, _) -> (_, _, false)
|# |#
(require scribble/srcdoc (require scribble/srcdoc
racket/contract/base racket/file) racket/contract/base racket/file)
(require/doc racket/base (require/doc racket/base scribble/manual (for-label racket/serialize))
scribble/manual
scribble/example
(for-label racket/serialize))
(define-struct (exn:unknown-preference exn) ()) (define-struct (exn:unknown-preference exn) ())
@ -45,31 +42,23 @@ the state transitions / contracts are:
(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-hasheq))
;; marshall-unmarshall : sym -o> un/marshall ;; marshall-unmarshall : sym -o> un/marshall
(define marshall-unmarshall (make-hasheq))
;; callbacks : sym -o> (listof (sym TST -> boolean)) ;; callbacks : sym -o> (listof (sym TST -> boolean))
(define callbacks (make-hasheq))
;; defaults : hash-table[sym -o> default] ;; defaults : hash-table[sym -o> default]
(struct preferences:layer (preferences marshall-unmarshall callbacks defaults prev)) (define defaults (make-hasheq))
(define (preferences:new-layer prev) ;; these four functions determine the state of a preference
(preferences:layer (make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq) prev)) (define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
(define preferences:current-layer (make-parameter (preferences:new-layer #f))) (define (preferences:default-set? pref) (hash-has-key? defaults pref))
(define (pref-can-init? pref)
(define (find-layer pref) (not (hash-has-key? preferences pref)))
(let loop ([pref-state (preferences:current-layer)])
(and pref-state
(cond
[(hash-has-key? (preferences:layer-defaults pref-state) pref)
pref-state]
[(hash-has-key? (preferences:layer-callbacks pref-state) pref)
pref-state]
[else
(loop (preferences:layer-prev pref-state))]))))
(define (preferences:default-set? pref)
(define layer (find-layer pref))
(and layer
(hash-has-key? (preferences:layer-defaults layer) 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))
@ -82,7 +71,7 @@ the state transitions / contracts are:
;; 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) #:transparent) (define-struct pref-callback (cb))
;; used to detect missing hash entries ;; used to detect missing hash entries
(define none (gensym 'none)) (define none (gensym 'none))
@ -91,53 +80,45 @@ the state transitions / contracts are:
;; 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)
(define pref-state (find-layer p))
(when (or (not pref-state)
(not (hash-has-key? (preferences:layer-defaults pref-state) p)))
(raise-unknown-preference-error
'preferences:get
"tried to get a preference but no default set for ~e"
p))
(define preferences (preferences:layer-preferences pref-state))
(define v (hash-ref preferences p none)) (define v (hash-ref preferences p none))
(cond (cond
;; if this is found, we can just return it immediately
[(not (eq? v none))
v]
;; first time reading this, check the file & unmarshall value, if ;; first time reading this, check the file & unmarshall value, if
;; it's not there, use the default ;; it's not there, use the default
[(eq? v none) [(preferences:default-set? p)
(define defaults (preferences:layer-defaults pref-state)) (let* (;; try to read the preference from the preferences file
;; try to read the preference from the preferences file [v (read-pref-from-file p)]
(define marshalled-v (read-pref-from-file (hash-ref defaults p) p)) [v (if (eq? v none)
(define default-info (hash-ref defaults p)) ;; no value read, take the default value
(define the-default-value (default-value default-info)) (default-value (hash-ref defaults p))
(define v (if (eq? marshalled-v none) ;; found a saved value, unmarshall it
;; no value read, take the default value (unmarshall-pref p v))])
the-default-value ;; set the value for future reference and return it
;; found a saved value, unmarshall it (hash-set! preferences p v)
(unmarshall-pref pref-state p marshalled-v v)]
(default-checker default-info) [(not (preferences:default-set? p))
the-default-value))) (raise-unknown-preference-error
;; set the value in the preferences table for easier reference 'preferences:get
;; and so we know it has been read from the disk "tried to get a preference but no default set for ~e"
;; (and thus setting the marshaller after this is no good) p)]))
(hash-set! preferences p v)
v]
;; oth. it is found, so we can just return it
[else v]))
;; read-pref-from-file : symbol -> (or/c any none) ;; read-pref-from-file : symbol -> (or/c any none)
;; reads the preference saved in the low-level preferences ;; reads the preference saved in the low-level preferences
;; file, first checking 'p' and then checking the aliases (in order) ;; file, first checking 'p' and then checking the aliases (in order)
(define (read-pref-from-file defaults p) (define (read-pref-from-file p)
(let loop ([syms (cons p (default-aliases defaults))] (let ([defaults (hash-ref defaults p)])
[rewriters (cons values (default-rewrite-aliases defaults))]) (let loop ([syms (cons p (default-aliases defaults))]
(cond [rewriters (cons values (default-rewrite-aliases defaults))])
[(null? syms) none] (cond
[else [(null? syms) none]
(let/ec k [else
((car rewriters) (let/ec k
((preferences:low-level-get-preference) ((car rewriters)
(add-pref-prefix (car syms)) ((preferences:low-level-get-preference)
(lambda () (k (loop (cdr syms) (cdr rewriters)))))))]))) (add-pref-prefix (car syms))
(lambda () (k (loop (cdr syms) (cdr rewriters)))))))]))))
;; set : symbol any -> void ;; set : symbol any -> void
;; updates the preference ;; updates the preference
@ -149,40 +130,40 @@ the state transitions / contracts are:
;; exported ;; exported
(define (multi-set ps values) (define (multi-set ps values)
(dynamic-wind (dynamic-wind
(λ () (λ ()
(call-pref-save-callbacks #t)) (call-pref-save-callbacks #t))
(λ () (λ ()
(for ([p (in-list ps)] (for-each
[value (in-list values)]) (λ (p value)
(define pref-state (find-layer p)) (cond
(cond [(preferences:default-set? p)
[pref-state (define default (hash-ref defaults p))
(define default (hash-ref (preferences:layer-defaults pref-state) p)) (define checker? (default-checker default))
(define checker? (default-checker default)) (unless (checker? value)
(unless (checker? value) (error 'preferences:set
(error 'preferences:set (string-append
(string-append "new value doesn't satisfy preferences:set-default predicate\n"
"new value doesn't satisfy preferences:set-default predicate\n" " pref sym: ~v\n"
" pref symbol: ~e\n" " given: ~e\n"
" given: ~e\n" " predicate: ~e")
" predicate: ~e") p value checker?))
p value checker?)) (check-callbacks p value)
(check-callbacks pref-state p value) (hash-set! preferences p value)]
(hash-set! (preferences:layer-preferences pref-state) p value)] [(not (preferences:default-set? p))
[else (raise-unknown-preference-error
(raise-unknown-preference-error 'preferences:set
'preferences:set (string-append
(string-append "cannot set preference before setting default"
"cannot set preference before setting default" " pref sym: ~e\n"
" pref symbol: ~e\n" " given: ~e")
" given: ~e") p
p value)]))
value)])) ps values)
((preferences:low-level-put-preferences) ((preferences:low-level-put-preferences)
(map add-pref-prefix ps) (map add-pref-prefix ps)
(for/list ([p (in-list ps)] (map (λ (p value) (marshall-pref p value))
[value (in-list values)]) ps
(marshall-pref p value))) values))
(void)) (void))
(λ () (λ ()
(call-pref-save-callbacks #f)))) (call-pref-save-callbacks #f))))
@ -220,41 +201,38 @@ the state transitions / contracts are:
(current-continuation-marks)))) (current-continuation-marks))))
;; add-callback : sym (-> void) -> void ;; add-callback : sym (-> void) -> void
(define (preferences:add-callback p callback [weak? #f]) (define preferences:add-callback
(define pref-state (or (find-layer p) (preferences:current-layer))) (lambda (p callback [weak? #f])
(define callbacks (preferences:layer-callbacks pref-state)) (let ([new-cb (make-pref-callback (if weak?
(define new-cb (impersonator-ephemeron callback)
(make-pref-callback (if weak? callback))])
(impersonator-ephemeron callback) (hash-set! callbacks
callback))) p
(hash-set! callbacks (append
p (hash-ref callbacks p '())
(append (list new-cb)))
(hash-ref callbacks p '()) (λ ()
(list new-cb))) (hash-set!
(λ () callbacks
(hash-set! p
callbacks (let loop ([callbacks (hash-ref callbacks p '())])
p (cond
(let loop ([callbacks (hash-ref callbacks p '())]) [(null? callbacks) '()]
(cond [else
[(null? callbacks) '()] (let ([callback (car callbacks)])
[else (cond
(let ([callback (car callbacks)]) [(eq? callback new-cb)
(cond (loop (cdr callbacks))]
[(eq? callback new-cb) [else
(loop (cdr callbacks))] (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
[else
(cons (car callbacks) (loop (cdr callbacks)))]))])))))
;; check-callbacks : pref-state sym val -> void ;; check-callbacks : sym val -> void
(define (check-callbacks pref-state p value) (define (check-callbacks p value)
(define callbacks (preferences:layer-callbacks pref-state))
(define new-callbacks (define new-callbacks
(let loop ([callbacks (hash-ref callbacks p '())]) (let loop ([callbacks (hash-ref callbacks p '())])
(cond (cond
[(null? callbacks) null] [(null? callbacks) null]
[else [else
(define callback (car callbacks)) (define callback (car callbacks))
(define cb (pref-callback-cb callback)) (define cb (pref-callback-cb callback))
(cond (cond
@ -274,137 +252,106 @@ the state transitions / contracts are:
(hash-set! 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)
(define pref-state (find-layer p))
(cond (cond
[pref-state [(and (preferences:default-set? p)
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state)) (not (pref-un/marshall-set? p))
(define pref-un/marshall-set? (hash-ref marshall-unmarshall p #f)) (pref-can-init? p))
(define pref-can-init? (not (hash-has-key? (preferences:layer-preferences pref-state) p))) (hash-set! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
(cond [(not (preferences:default-set? p))
[(and (not pref-un/marshall-set?) pref-can-init?)
(hash-set! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
[pref-un/marshall-set?
(error 'preferences:set-un/marshall
"already set un/marshall for ~e"
p)]
[(not pref-can-init?)
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])]
[else
(error 'preferences:set-un/marshall (error 'preferences:set-un/marshall
"must call preferences:set-default for ~s before calling set-un/marshall for ~s" "must call set-default for ~s before calling set-un/marshall for ~s"
p p)])) p p)]
[(pref-un/marshall-set? p)
(error 'preferences:set-un/marshall
"already set un/marshall for ~e"
p)]
[(not (pref-can-init? p))
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
(define (preferences:restore-defaults)
(hash-for-each
defaults
(λ (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
#:aliases [aliases '()] #:aliases [aliases '()]
#:rewrite-aliases [rewrite-aliases (map (λ (x) values) aliases)]) #:rewrite-aliases [rewrite-aliases (map (lambda (x) values) aliases)])
(define pref-state (or (find-layer p) (preferences:current-layer))) (cond
(define defaults (preferences:layer-defaults pref-state)) [(and (not (preferences:default-set? p))
(when (hash-has-key? defaults p) (pref-can-init? p))
(error 'preferences:set-default (define default-okay? (checker default-value))
(string-append (unless default-okay?
"preferences default already set\n" (error 'set-default
" pref symbol: ~e\n" (string-append
" default: ~e\n" "checker doesn't match default\n"
" checker: ~e") " default: ~e\n"
p default-value checker)) " pref sym: ~e\n"
(unless (checker default-value) " checker: ~e")
(error 'preferences:set-default p default-value checker))
(string-append
"checker doesn't match default\n" (unless (= (length aliases) (length rewrite-aliases))
" pref symbol: ~e\n" (error 'preferences:set-default
" default: ~e\n" "expected equal length lists for the #:aliases and #:rewrite-aliases arguments, got ~e and ~e"
" checker: ~e") aliases rewrite-aliases))
p default-value checker)) (hash-set! defaults p (make-default default-value checker aliases rewrite-aliases))]
(unless (= (length aliases) (length rewrite-aliases)) [(not (pref-can-init? p))
(error 'preferences:set-default (error 'preferences:set-default
(string-append "tried to call set-default for preference ~e but it cannot be configured any more"
"expected equal length lists for the #:aliases" p)]
" and #:rewrite-aliases arguments, got ~e and ~e") [(preferences:default-set? p)
aliases rewrite-aliases)) (error 'preferences:set-default
(hash-set! defaults p (make-default default-value checker aliases rewrite-aliases))) "preferences default already set for ~e" p)]
[(not (pref-can-init? p))
(error 'preferences:set-default
"can no longer set the default for ~e" p)]))
;; marshall-pref : symbol any -> (list symbol printable) ;; marshall-pref : symbol any -> (list symbol printable)
(define (marshall-pref p value) (define (marshall-pref p value)
(define pref-state (find-layer p))
(let/ec k (let/ec k
(define marshaller (let* ([marshaller
(un/marshall-marshall (un/marshall-marshall
(hash-ref (preferences:layer-marshall-unmarshall pref-state) (hash-ref marshall-unmarshall p (λ () (k value))))])
p (marshaller value))))
(λ () (k value)))))
(marshaller value)))
;; unmarshall-pref : pref-state symbol marshalled (any -> bool) any -> any ;; unmarshall-pref : symbol marshalled -> any
;; unmarshalls a preference read from the disk ;; unmarshalls a preference read from the disk
(define (unmarshall-pref pref-state p data the-checker the-default-value) (define (unmarshall-pref p data)
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state)) (let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
(define un/marshall (hash-ref marshall-unmarshall p #f)) [result (if un/marshall
(define result ((un/marshall-unmarshall un/marshall) data)
(if un/marshall data)]
((un/marshall-unmarshall un/marshall) data) [default (hash-ref defaults p)])
data)) (if ((default-checker default) result)
(if (the-checker result) result
result (default-value default))))
the-default-value))
;; copy-pref-value : sym any -> any ;; copy-pref-value : sym any -> any
;; uses the marshalling code to copy a preference. If there ;; uses the marshalling code to copy a preference. If there
;; is not marshaller set, then no copying happens. ;; is not marshaller set, then no copying happens.
(define (copy-pref-value p value) (define (copy-pref-value p value)
(let/ec k (let/ec k
(define pref-state (find-layer p)) (let* ([un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))]
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state)) [default (hash-ref defaults p)]
(define un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))) [marsh (un/marshall-marshall un/marshaller)]
(define default (hash-ref (preferences:layer-defaults pref-state) p)) [unmarsh (un/marshall-unmarshall un/marshaller)]
(define marsh (un/marshall-marshall un/marshaller)) [marshalled (marsh value)]
(define unmarsh (un/marshall-unmarshall un/marshaller)) [copy (unmarsh marshalled)])
(define marshalled (marsh value)) (if ((default-checker default) copy)
(define copy (unmarsh marshalled)) copy
(if ((default-checker default) copy) value))))
copy
value)))
(define (preferences:restore-defaults)
(let loop ([prefs-state (preferences:current-layer)])
(when prefs-state
(for ([(p def) (in-hash (preferences:layer-defaults prefs-state))])
(preferences:set p (default-value def)))
(loop (preferences:layer-prev prefs-state)))))
(define-struct preferences:snapshot (x)) (define-struct preferences:snapshot (x))
(define (preferences:get-prefs-snapshot) (define (preferences:get-prefs-snapshot)
(make-preferences:snapshot (make-preferences:snapshot
(let loop ([prefs-state (preferences:current-layer)] (hash-map defaults
[sofar '()]) (λ (k v) (cons k (copy-pref-value k (preferences:get k)))))))
(cond
[prefs-state
(loop (preferences:layer-prev prefs-state)
(for/fold ([sofar sofar])
([(k def) (in-hash (preferences:layer-defaults prefs-state))])
(cons (cons k (copy-pref-value k (preferences:get k)))
sofar)))]
[else sofar]))))
(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))
(begin-for-doc
(define pref-layer-eval (make-base-eval))
(pref-layer-eval
'(begin
(require framework/preferences)
(let ([the-prefs-table (make-hash)])
(preferences:low-level-put-preferences
(λ (syms vals)
(for ([sym (in-list syms)]
[val (in-list vals)])
(hash-set! the-prefs-table sym val))))
(preferences:low-level-get-preference
(λ (sym [fail void])
(hash-ref the-prefs-table sym fail)))))))
(provide/doc (provide/doc
(proc-doc/names (proc-doc/names
@ -412,7 +359,7 @@ the state transitions / contracts are:
(symbol? . -> . any/c) (symbol? . -> . any/c)
(symbol) (symbol)
@{See also @racket[preferences:set-default]. @{See also @racket[preferences:set-default].
@racket[preferences:get] returns the value for the preference @racket[preferences:get] returns the value for the preference
@racket[symbol]. It raises an exception matching @racket[symbol]. It raises an exception matching
@racket[exn:unknown-preference?] @racket[exn:unknown-preference?]
@ -425,12 +372,12 @@ the state transitions / contracts are:
@{Sets the preference @{Sets the preference
@racket[symbol] to @racket[value]. It should be called when the @racket[symbol] to @racket[value]. It should be called when the
user requests a change to a preference. user requests a change to a preference.
@racket[preferences:set] immediately writes the preference value to disk. @racket[preferences:set] immediately writes the preference value to disk.
It raises an exception matching It raises an exception matching
@racket[exn:unknown-preference?] @racket[exn:unknown-preference?]
if the preference's default has not been set if the preference's default has not been set
See also @racket[preferences:set-default].}) See also @racket[preferences:set-default].})
(proc-doc/names (proc-doc/names
@ -442,10 +389,10 @@ the state transitions / contracts are:
applied to one argument updates the preference named @racket[pref]. applied to one argument updates the preference named @racket[pref].
@history[#:added "1.18"]{}}) @history[#:added "1.18"]{}})
(proc-doc/names (proc-doc/names
preferences:add-callback preferences:add-callback
(->* (symbol? (-> symbol? any/c any)) (->* (symbol? (-> symbol? any/c any))
(boolean?) (boolean?)
(-> void?)) (-> void?))
((p f) ((p f)
@ -454,23 +401,19 @@ the state transitions / contracts are:
preference and its value, when the preference changes. preference and its value, when the preference changes.
@racket[preferences:add-callback] returns a thunk, which when @racket[preferences:add-callback] returns a thunk, which when
invoked, removes the callback from this preference. invoked, removes the callback from this preference.
If @racket[weak?] is true, the preferences system will only hold on to If @racket[weak?] is true, the preferences system will only hold on to
the callback the callback
@tech[#:key "weak references" @tech[#:key "weak references"
#:doc '(lib "scribblings/reference/reference.scrbl")]{weakly}. #:doc '(lib "scribblings/reference/reference.scrbl")]{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
@racket[preferences:set-un/marshall] before adding a callback. @racket[preferences:set-un/marshall] before adding a callback.
The result thunk removes the callback from the same @tech{preferences layer}
that @racket[p] was in when @racket[preferences:add-callback] was
originally called.
This function raises an exception matching This function raises an exception matching
@racket[exn:unknown-preference?] @racket[exn:unknown-preference?]
if the preference default has not been set via if the preference default has not been set via
@ -486,16 +429,16 @@ the state transitions / contracts are:
@{This function must be called every time your application starts up, before @{This function must be called every time your application starts up, before
any call to @racket[preferences:get] or @racket[preferences:set] any call to @racket[preferences:get] or @racket[preferences:set]
(for any given preference). (for any given preference).
If you use @racket[preferences:set-un/marshall], If you use @racket[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 @racket[symbol] to This sets the default value of the preference @racket[symbol] to
@racket[value]. If the user has chosen a different setting, @racket[value]. If the user has chosen a different setting,
(reflected via a call to @racket[preferences:set], possibly (reflected via a call to @racket[preferences:set], possibly
in a different run of your program), in a different run of your program),
the user's setting will take precedence over the default value. the user's setting will take precedence over the default value.
The @racket[test] argument is used as a safeguard. That function is The @racket[test] argument 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 @racket[test] returns @racket[#t], then the preference is preference. If @racket[test] returns @racket[#t], then the preference is
@ -503,7 +446,7 @@ the state transitions / contracts are:
used. used.
The @racket[aliases] and @racket[rewrite-aliases] arguments aids The @racket[aliases] and @racket[rewrite-aliases] arguments aids
in renaming preferences. If @racket[aliases] is present, it is in renaming preferences. If @racket[aliases] is present, it is
expected to be a list of symbols that correspond to old versions expected to be a list of symbols that correspond to old versions
of the preferences. It defaults to @racket['()]. If @racket[rewrite-aliases] of the preferences. It defaults to @racket['()]. If @racket[rewrite-aliases]
is present, it is used to adjust the old values of the preferences is present, it is used to adjust the old values of the preferences
@ -512,7 +455,7 @@ the state transitions / contracts are:
@history[#:changed "1.23" @list{Allow @racket[preferences:set-default] @history[#:changed "1.23" @list{Allow @racket[preferences:set-default]
to be called even after a snapshot has been grabbed.}] to be called even after a snapshot has been grabbed.}]
}) })
(proc-doc/names (proc-doc/names
preferences:default-set? preferences:default-set?
(-> symbol? boolean?) (-> symbol? boolean?)
@ -534,113 +477,107 @@ the state transitions / contracts are:
into its internal representation. If @racket[preferences:set-un/marshall] into its internal representation. If @racket[preferences: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 If the unmarshalling function returns a value that does not meet the
guard passed to @racket[preferences:set-default] guard passed to @racket[preferences:set-default]
for this preference, the default value is used. for this preference, the default value is used.
The @racket[marshall] function might be called with any value returned The @racket[marshall] function might be called with any value returned
from @racket[read] and it must not raise an error from @racket[read] and it must not raise an error
(although it can return arbitrary results if it gets bad input). This might (although it can return arbitrary results if it gets bad input). This might
happen when the preferences file becomes corrupted, or is edited happen when the preferences file becomes corrupted, or is edited
by hand. by hand.
@racket[preferences:set-un/marshall] must be called before calling @racket[preferences:set-un/marshall] must be called before calling
@racket[preferences:get],@racket[preferences:set]. @racket[preferences:get],@racket[preferences:set].
See also @racket[serialize] and @racket[deserialize]. See also @racket[serialize] and @racket[deserialize].
}) })
(proc-doc/names (proc-doc/names
preferences:restore-defaults preferences:restore-defaults
(-> void?) (-> void?)
() ()
@{@racket[(preferences:restore-defaults)] restores the users' configuration @{@racket[(preferences:restore-defaults)] restores the users' configuration
to the default preferences.}) to the default preferences.})
(proc-doc/names (proc-doc/names
preferences:register-save-callback preferences:register-save-callback
(-> (-> boolean? any) symbol?) (-> (-> boolean? any) symbol?)
(callback) (callback)
@{Registers @racket[callback] to run twice for each call @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once
to @racket[preferences:set]---once before the preferences before the preferences file is written, with @racket[#t], and once after it is written, with
file is written, with @racket[#t], and once after it is @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback].
written, with @racket[#f]. Registration returns a key for Caveats:
use with @racket[preferences:unregister-save-callback]. @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].}
Caveats: @itemize{ @item{Pre- and post-write notifications are not necessarily paired; unregistration
@item{The callback occurs on whichever may cancel the post-write notification before it occurs.}}})
thread happened to call @racket[preferences:set].
}
@item{
Pre- and post-write notifications are not necessarily
paired; unregistration may cancel the post-write
notification before it occurs.}}})
(proc-doc/names (proc-doc/names
preferences:unregister-save-callback preferences:unregister-save-callback
(-> symbol? void?) (-> symbol? void?)
(key) (key)
@{Unregisters the save callback associated with @racket[key].}) @{Unregisters the save callback associated with @racket[key].})
(proc-doc/names (proc-doc/names
exn:make-unknown-preference 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.})
(proc-doc/names (proc-doc/names
exn:unknown-preference? 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.})
(thing-doc (thing-doc
exn:struct:unknown-preference exn:struct:unknown-preference
struct-type? struct-type?
@{The struct type for the unknown preference exn.}) @{The struct type for the unknown preference exn.})
(parameter-doc (parameter-doc
preferences:low-level-put-preferences preferences:low-level-put-preferences
(parameter/c (-> (listof symbol?) (listof any/c) any)) (parameter/c ((listof symbol?) (listof any/c) . -> . any))
put-preferences put-preferences
@{This parameter's value is called to save preference the preferences file. @{This parameter's value is called to save preference the preferences file.
Its interface should be just like mzlib's @racket[put-preferences]. Its interface should be just like mzlib's @racket[put-preferences].
The default value calls @racket[put-preferences] and, if there is an error, The default value calls @racket[put-preferences] and, if there is an error,
then starts using a hash-table to save the preferences instead. then starts using a hash-table to save the preferences instead.
See also @racket[]}) See also @racket[]})
(parameter-doc (parameter-doc
preferences:low-level-get-preference preferences:low-level-get-preference
(parameter/c (->* (symbol?) [(-> any)] any)) (parameter/c (->* (symbol?) [(-> any)] any))
get-preference get-preference
@{This parameter's value is called to get a preference from the preferences @{This parameter's value is called to get a preference from the preferences
file. Its interface should be just like @racket[get-preference]. file. Its interface should be just like @racket[get-preference].
The default value calls @racket[get-preferences] and, if there is an error, The default value calls @racket[get-preferences] and, if there is an error,
then starts using a hash-table to save the preferences instead.}) then starts using a hash-table to save the preferences instead.})
(proc-doc/names (proc-doc/names
preferences:snapshot? 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 @racket[preferences:get-prefs-snapshot] and See also @racket[preferences:get-prefs-snapshot] and
@racket[preferences:restore-prefs-snapshot].}) @racket[preferences:restore-prefs-snapshot].})
(proc-doc/names (proc-doc/names
preferences:restore-prefs-snapshot preferences:restore-prefs-snapshot
(-> preferences:snapshot? void?) (-> preferences:snapshot? void?)
(snapshot) (snapshot)
@{Restores the preferences saved in @racket[snapshot], updating @{Restores the preferences saved in @racket[snapshot], updating
all of the preferences values to the ones they had at the time all of the preferences values to the ones they had at the time
that @racket[preferences:get-prefs-snapshot] was called. that @racket[preferences:get-prefs-snapshot] was called.
See also @racket[preferences:get-prefs-snapshot].}) See also @racket[preferences:get-prefs-snapshot].})
(proc-doc/names (proc-doc/names
preferences:get-prefs-snapshot preferences:get-prefs-snapshot
(-> preferences:snapshot?) (-> preferences:snapshot?)
() ()
@{Caches all of the current values of the known preferences and returns them. @{Caches all of the current values of the known preferences and returns them.
@ -649,64 +586,4 @@ the state transitions / contracts are:
copied by passing it through the marshalling and unmarshalling process. copied by passing it through the marshalling and unmarshalling process.
Other values are not copied, but references to them are instead saved. Other values are not copied, but references to them are instead saved.
See also @racket[preferences:restore-prefs-snapshot].}) See also @racket[preferences:restore-prefs-snapshot].}))
(proc-doc/names
preferences:new-layer
(-> (or/c #f preferences:layer?) preferences:layer?)
(previous-preferences-layer)
@{Creates a @tech{preferences layer} that extends @racket[previous-preferences-layer].
@history[#:added "1.30"]})
(proc-doc/names
preferences:layer?
(-> any/c boolean?)
(v)
@{Determines if @racket[v] is a @deftech{preferences layer}.
A preferences layer gives a form of scoping to preferences. When
a new preference is first registered with this library (via a call to
@racket[preferences:set-default] or @racket[preferences:add-callback])
it is put into the layer in @racket[preferences:current-layer]
(and not into any of that layer's previous layers).
When @racket[preferences:get], @racket[preferences:set],
@racket[preferences:set-un/marshall] are called, they consult and
manipulate only the layer where the preference was first installed.
Accordingly, preference layers give a way to discard some set of
calls to @racket[preference:set-default] and other preference configuration
and to start over with a new set. Note that this affects only the configuration
of the preferences for the library; the values are all stored centrally
(see @racket[preferences:low-level-put-preferences]) and are unaffected
by the layers.
@examples[#:eval pref-layer-eval
(define original-layer (preferences:current-layer))
(define layer2 (preferences:new-layer original-layer))
(parameterize ([preferences:current-layer layer2])
(code:comment "initialize 'a-pref in layer2")
(preferences:set-default 'a-pref 5 real?)
(preferences:set 'a-pref 6)
(preferences:get 'a-pref))
(define layer3 (preferences:new-layer original-layer))
(parameterize ([preferences:current-layer layer3])
(code:comment "initialize 'a-pref again, this time in layer3")
(code:comment "without the new layer in place, this would be an error")
(preferences:set-default 'a-pref 5 real?)
(code:comment "the actual value of the preference remains")
(code:comment "from the previous call to preferences:set")
(preferences:get 'a-pref))]
@history[#:added "1.30"]
})
(parameter-doc
preferences:current-layer
(parameter/c preferences:layer?)
preferences-layer
@{Determines the current @tech{preferences layer}.
@history[#:added "1.30"]})
)

3
gui-lib/framework/private/autosave.rkt
View File

@ -256,8 +256,7 @@
(string-constant autosave-delete-title) (string-constant autosave-delete-title)
(string-constant cancel) (string-constant cancel)
(string-constant warning) (string-constant warning)
#f #f)
#:dialog-mixin frame:focus-table-mixin)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(λ (exn) (λ (exn)
(message-box (message-box

52
gui-lib/framework/private/color-prefs.rkt
View File

@ -157,43 +157,21 @@
hp)] hp)]
[callback [callback
(λ (color-button evt) (λ (color-button evt)
(define pref (get-from-pref-sym)) (let* ([add (send (get-from-pref-sym) get-foreground-add)]
(define orig-add (send pref get-foreground-add)) [color (make-object color%
(define orig-mult (send pref get-foreground-mult)) (send add get-r)
(define (avg x y z) (/ (+ x y z) 3)) (send add get-g)
(define (pin-between lo x hi) (min (max lo x) hi)) (send add get-b))]
(define orig-α [users-choice
(- 1 (pin-between 0 (get-color-from-user
(avg (send orig-mult get-r) (format (string-constant syntax-coloring-choose-color) example-text)
(send orig-mult get-g) (send color-button get-top-level-window)
(send orig-mult get-b)) color
1))) '(alpha))])
(define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255)) (when users-choice
(define color (update-style-delta
(make-object color% (λ (delta)
(to-byte (- 255 (/ (- 255 (send orig-add get-r)) orig-α))) (send delta set-delta-foreground users-choice))))))])))
(to-byte (- 255 (/ (- 255 (send orig-add get-g)) orig-α)))
(to-byte (- 255 (/ (- 255 (send orig-add get-b)) orig-α)))
orig-α))
(define users-choice
(get-color-from-user
(format (string-constant syntax-coloring-choose-color) example-text)
(send color-button get-top-level-window)
color
'(alpha)))
(when users-choice
(update-style-delta
(λ (delta)
(define new-α (send users-choice alpha))
(define α*users-choice
(make-object color%
(to-byte (- 255 (* (- 255 (send users-choice red)) new-α)))
(to-byte (- 255 (* (- 255 (send users-choice green)) new-α)))
(to-byte (- 255 (* (- 255 (send users-choice blue)) new-α)))))
(send delta set-delta-foreground α*users-choice)
(define new-mult (send delta get-foreground-mult))
(send new-mult set (- 1 new-α) (- 1 new-α) (- 1 new-α))))))])))
(define background-color-button (define background-color-button
(and (>= (get-display-depth) 8) (and (>= (get-display-depth) 8)
background? background?

69
gui-lib/framework/private/color.rkt
View File

@ -27,8 +27,7 @@ added get-regions
[prefix mode: framework:mode^] [prefix mode: framework:mode^]
[prefix text: framework:text^] [prefix text: framework:text^]
[prefix color-prefs: framework:color-prefs^] [prefix color-prefs: framework:color-prefs^]
[prefix racket: framework:racket^] [prefix racket: framework:racket^])
[prefix number-snip: framework:number-snip/int^])
(export (rename framework:color^ (export (rename framework:color^
(-text<%> text<%>) (-text<%> text<%>)
@ -209,9 +208,7 @@ added get-regions
(and (null? (cdr regions)) (and (null? (cdr regions))
(eq? 'end (list-ref region 1))))) (eq? 'end (list-ref region 1)))))
(error 'reset-regions (error 'reset-regions
(string-append "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e"
"got a region that is not a list of two numbers"
" (or 'end if it is the last region): ~e, all regions ~e")
region region
regions)) regions))
(unless (and (<= pos (list-ref region 0)) (unless (and (<= pos (list-ref region 0))
@ -264,13 +261,13 @@ added get-regions
(spell-checking-values-changed))) (spell-checking-values-changed)))
(define/private (spell-checking-values-changed) (define/private (spell-checking-values-changed)
(reset-tokens) (reset-tokens)
(_start-colorer token-sym->style get-token pairs)) (start-colorer token-sym->style get-token pairs))
(define current-dict (preferences:get 'framework:aspell-dict)) (define current-dict (preferences:get 'framework:aspell-dict))
(define/public (set-spell-current-dict d) (define/public (set-spell-current-dict d)
(unless (equal? d current-dict) (unless (equal? d current-dict)
(set! current-dict d) (set! current-dict d)
(reset-tokens) (reset-tokens)
(_start-colorer token-sym->style get-token pairs))) (start-colorer token-sym->style get-token pairs)))
(define/public (get-spell-current-dict) current-dict) (define/public (get-spell-current-dict) current-dict)
;; ---------------------- Multi-threading --------------------------- ;; ---------------------- Multi-threading ---------------------------
@ -340,11 +337,7 @@ added get-regions
(open-input-text-editor this (open-input-text-editor this
(lexer-state-current-pos ls) (lexer-state-current-pos ls)
(lexer-state-end-pos ls) (lexer-state-end-pos ls)
(λ (x) (λ (x) #f)))
(cond
[(number-snip:is-number-snip? x)
x]
[else #f]))))
(port-count-lines! in) (port-count-lines! in)
(continue-re-tokenize start-time ok-to-stop? ls in (continue-re-tokenize start-time ok-to-stop? ls in
(lexer-state-current-pos ls) (lexer-state-current-pos ls)
@ -364,8 +357,7 @@ added get-regions
#f] #f]
[else [else
(define-values (_line1 _col1 pos-before) (port-next-location in)) (define-values (_line1 _col1 pos-before) (port-next-location in))
(define-values (lexeme type data new-token-start new-token-end (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode/cont)
backup-delta new-lexer-mode/cont)
(get-token in in-start-pos lexer-mode)) (get-token in in-start-pos lexer-mode))
(define-values (_line2 _col2 pos-after) (port-next-location in)) (define-values (_line2 _col2 pos-after) (port-next-location in))
(define new-lexer-mode (if (dont-stop? new-lexer-mode/cont) (define new-lexer-mode (if (dont-stop? new-lexer-mode/cont)
@ -379,12 +371,10 @@ added get-regions
[else [else
(unless (<= pos-before new-token-start pos-after) (unless (<= pos-before new-token-start pos-after)
(error 'color:text<%> (error 'color:text<%>
"expected the token start to be between ~s and ~s, got ~s" "expected the token start to be between ~s and ~s, got ~s" pos-before pos-after new-token-start))
pos-before pos-after new-token-start))
(unless (<= pos-before new-token-end pos-after) (unless (<= pos-before new-token-end pos-after)
(error 'color:text<%> (error 'color:text<%>
"expected the token end to be between ~s and ~s, got ~s" "expected the token end to be between ~s and ~s, got ~s" pos-before pos-after new-token-end))
pos-before pos-after new-token-end))
(let ((len (- new-token-end new-token-start))) (let ((len (- new-token-end new-token-start)))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
(set-lexer-state-current-lexer-mode! ls new-lexer-mode) (set-lexer-state-current-lexer-mode! ls new-lexer-mode)
@ -395,9 +385,7 @@ added get-regions
;; version. In other words, the new greatly outweighs the tree ;; version. In other words, the new greatly outweighs the tree
;; operations. ;; operations.
;;(insert-last! tokens (new token-tree% (length len) (data type))) ;;(insert-last! tokens (new token-tree% (length len) (data type)))
(insert-last-spec! (lexer-state-tokens ls) (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta))
len
(make-data type new-lexer-mode backup-delta))
#; (show-tree (lexer-state-tokens ls)) #; (show-tree (lexer-state-tokens ls))
(send (lexer-state-parens ls) add-token data len) (send (lexer-state-parens ls) add-token data len)
(cond (cond
@ -415,8 +403,7 @@ added get-regions
(set-lexer-state-up-to-date?! ls #t) (set-lexer-state-up-to-date?! ls #t)
(re-tokenize-move-to-next-ls start-time next-ok-to-stop?)] (re-tokenize-move-to-next-ls start-time next-ok-to-stop?)]
[else [else
(continue-re-tokenize start-time next-ok-to-stop? (continue-re-tokenize start-time next-ok-to-stop? ls in in-start-pos new-lexer-mode)]))])]))
ls in in-start-pos new-lexer-mode)]))])]))
(define/private (add-colorings type in-start-pos new-token-start new-token-end) (define/private (add-colorings type in-start-pos new-token-start new-token-end)
(define sp (+ in-start-pos (sub1 new-token-start))) (define sp (+ in-start-pos (sub1 new-token-start)))
@ -430,8 +417,7 @@ added get-regions
[else #f])) [else #f]))
(cond (cond
[do-spell-check? [do-spell-check?
(define misspelled-color (define misspelled-color (send (get-style-list) find-named-style misspelled-text-color-style-name))
(send (get-style-list) find-named-style misspelled-text-color-style-name))
(cond (cond
[misspelled-color [misspelled-color
(define spell-infos (define spell-infos
@ -511,13 +497,12 @@ added get-regions
(set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data))) (set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data)))
(let ([start (+ (lexer-state-start-pos ls) orig-token-start)]) (let ([start (+ (lexer-state-start-pos ls) orig-token-start)])
(set-lexer-state-current-pos! ls start) (set-lexer-state-current-pos! ls start)
(set-lexer-state-current-lexer-mode! (set-lexer-state-current-lexer-mode! ls
ls (if (= start (lexer-state-start-pos ls))
(if (= start (lexer-state-start-pos ls)) #f
#f (begin
(begin (send valid-tree search-max!)
(send valid-tree search-max!) (data-lexer-mode (send valid-tree get-root-data))))))
(data-lexer-mode (send valid-tree get-root-data))))))
(set-lexer-state-up-to-date?! ls #f) (set-lexer-state-up-to-date?! ls #f)
(update-lexer-state-observers) (update-lexer-state-observers)
(queue-callback (λ () (colorer-callback)) #f))) (queue-callback (λ () (colorer-callback)) #f)))
@ -539,8 +524,7 @@ added get-regions
(split-backward ls (lexer-state-tokens ls) edit-start-pos))) (split-backward ls (lexer-state-tokens ls) edit-start-pos)))
(send (lexer-state-parens ls) truncate tok-start) (send (lexer-state-parens ls) truncate tok-start)
(set-lexer-state-tokens! ls valid-tree) (set-lexer-state-tokens! ls valid-tree)
(set-lexer-state-invalid-tokens-start! (set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls)))
ls (+ change-length (lexer-state-invalid-tokens-start ls)))
(let ([start (+ (lexer-state-start-pos ls) tok-start)]) (let ([start (+ (lexer-state-start-pos ls) tok-start)])
(set-lexer-state-current-pos! ls start) (set-lexer-state-current-pos! ls start)
(set-lexer-state-current-lexer-mode! (set-lexer-state-current-lexer-mode!
@ -609,7 +593,7 @@ added get-regions
(loop))))) (loop)))))
;; See docs ;; See docs
(define/private (_start-colorer token-sym->style- get-token- pairs-) (define/public (start-colorer token-sym->style- get-token- pairs-)
(unless force-stop? (unless force-stop?
(set! stopped? #f) (set! stopped? #f)
(reset-tokens) (reset-tokens)
@ -630,9 +614,6 @@ added get-regions
lexer-states) lexer-states)
;; (set! timer (current-milliseconds)) ;; (set! timer (current-milliseconds))
(do-insert/delete-all))) (do-insert/delete-all)))
(define/public (start-colorer token-sym->style- get-token- pairs-)
(_start-colorer token-sym->style- get-token- pairs-))
;; See docs ;; See docs
(define/public stop-colorer (define/public stop-colorer
@ -684,7 +665,7 @@ added get-regions
(gt get-token) (gt get-token)
(p pairs)) (p pairs))
(stop-colorer (not should-color?)) (stop-colorer (not should-color?))
(_start-colorer tn gt p))) (start-colorer tn gt p)))
(else (else
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(finish-now) (finish-now)
@ -1055,7 +1036,10 @@ added get-regions
(define tree (lexer-state-tokens ls)) (define tree (lexer-state-tokens ls))
(send tree search! (- next-pos ls-start)) (send tree search! (- next-pos ls-start))
(define start-pos (+ ls-start (send tree get-root-start-position))) (define start-pos (+ ls-start (send tree get-root-start-position)))
(define end-pos (+ ls-start (send tree get-root-end-position))) (define end-pos (+ ls-start (send tree get-root-end-position)))
#;(printf "~a |~a| |~a|~n" (list pos next-pos start-pos end-pos (send tree get-root-data)) closers (get-text start-pos end-pos))
(cond (cond
[(or (not (send tree get-root-data)) (<= end-pos pos)) [(or (not (send tree get-root-data)) (<= end-pos pos))
(values #f #f #f #f)] ;; didn't find /any/ token ending after pos (values #f #f #f #f)] ;; didn't find /any/ token ending after pos
@ -1322,7 +1306,7 @@ added get-regions
(define -text% (text-mixin text:keymap%)) (define -text% (text-mixin text:keymap%))
(define -text-mode<%> (interface () set-get-token)) (define -text-mode<%> (interface ()))
(define text-mode-mixin (define text-mode-mixin
(mixin (mode:surrogate-text<%>) (-text-mode<%>) (mixin (mode:surrogate-text<%>) (-text-mode<%>)
@ -1339,9 +1323,6 @@ added get-regions
(define/override (on-enable-surrogate text) (define/override (on-enable-surrogate text)
(super on-enable-surrogate text) (super on-enable-surrogate text)
(send text start-colorer token-sym->style get-token matches)) (send text start-colorer token-sym->style get-token matches))
(define/public (set-get-token _get-token)
(set! get-token _get-token))
(super-new))) (super-new)))

6
gui-lib/framework/private/editor.rkt
View File

@ -154,8 +154,7 @@
(string-constant cancel) (string-constant cancel)
(string-constant warning) (string-constant warning)
#f #f
(get-top-level-window) (get-top-level-window))
#:dialog-mixin frame:focus-table-mixin)
#t) #t)
#t) #t)
(inner #t can-save-file? filename format))) (inner #t can-save-file? filename format)))
@ -586,8 +585,7 @@
#t #t
(or (get-top-level-window) (or (get-top-level-window)
(get-can-close-parent)) (get-can-close-parent))
allow-cancel? allow-cancel?)
#:dialog-mixin frame:focus-table-mixin)
[(continue) #t] [(continue) #t]
[(save) (save-file)] [(save) (save-file)]
[else #f]))) [else #f])))

6
gui-lib/framework/private/exit.rkt
View File

@ -6,8 +6,7 @@
"../gui-utils.rkt" "../gui-utils.rkt"
mred/mred-sig) mred/mred-sig)
(import mred^ (import mred^)
[prefix frame: framework:frame^])
(export (rename framework:exit^ (export (rename framework:exit^
(-exit exit))) (-exit exit)))
@ -61,8 +60,7 @@
'app 'app
(case-lambda (case-lambda
[() (not (preferences:get 'framework:verify-exit))] [() (not (preferences:get 'framework:verify-exit))]
[(new) (preferences:set 'framework:verify-exit (not new))]) [(new) (preferences:set 'framework:verify-exit (not new))]))
#:dialog-mixin frame:focus-table-mixin)
#t)) #t))
(define (-exit) (define (-exit)

126
gui-lib/framework/private/frame.rkt
View File

@ -738,25 +738,6 @@
(define magic-space 25) (define magic-space 25)
(define-local-member-name get-memory-use-canvas)
(define memory-use-timer-cell (make-thread-cell #f))
(define (update-memory-use-canvases)
(define found-any? #f)
(for ([window (in-list (get-top-level-windows))])
(when (is-a? window frame:info<%>)
(set! found-any? #t)
(send (send window get-memory-use-canvas) update-memory-use-if-bigish-change)))
(unless found-any?
(send (thread-cell-ref memory-use-timer-cell) stop)
(thread-cell-set! memory-use-timer-cell #f)))
(define (maybe-create-memory-use-timer)
(unless (thread-cell-ref memory-use-timer-cell)
(when (eq? (current-thread) (eventspace-handler-thread (current-eventspace)))
(thread-cell-set! memory-use-timer-cell
(new timer%
[notify-callback update-memory-use-canvases]
[interval 1000])))))
(define info-mixin (define info-mixin
(mixin (basic<%>) (info<%>) (mixin (basic<%>) (info<%>)
[define rest-panel 'uninitialized-root] [define rest-panel 'uninitialized-root]
@ -871,35 +852,55 @@
(new grow-box-spacer-pane% [parent outer-info-panel]) (new grow-box-spacer-pane% [parent outer-info-panel])
(define/public (get-info-panel) info-panel) (define/public (get-info-panel) info-panel)
(define/public (get-memory-use-canvas) this-frames-memory-canvas) (define/public (update-memory-text)
(for ([memory-canvas (in-list memory-canvases)])
(send memory-canvas set-str (format-number (current-memory-use)))))
(define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)]
[before-decimal (floor mbytes)]
[after-decimal (modulo (floor (* mbytes 100)) 100)])
(string-append
(number->string before-decimal)
"."
(cond
[(<= after-decimal 9) (format "0~a" after-decimal)]
[else (number->string after-decimal)])
" MB")))
(define/private (pad-to-3 n)
(cond
[(<= n 9) (format "00~a" n)]
[(<= n 99) (format "0~a" n)]
[else (number->string n)]))
(define pref-save-canvas #f) (define pref-save-canvas #f)
(set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)])) (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))
[define lock-canvas (make-object lock-canvas% (get-info-panel))] [define lock-canvas (make-object lock-canvas% (get-info-panel))]
(define this-frames-memory-canvas #f)
; set up the memory use display in the status line ; set up the memory use display in the status line
(let* ([panel (new horizontal-panel% (let* ([panel (new horizontal-panel%
[parent (get-info-panel)] [parent (get-info-panel)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])]) [stretchable-height #f])]
(set! this-frames-memory-canvas [ec (new position-canvas%
(new memory-position-canvas% [parent panel]
[parent panel] [button-up
[button-up (λ (evt)
(λ (evt) (cond
(cond [(or (send evt get-alt-down)
[(or (send evt get-alt-down) (send evt get-control-down))
(send evt get-control-down)) (dynamic-require 'framework/private/follow-log #f)]
(dynamic-require 'framework/private/follow-log #f)] [else
[else (collect-garbage)
(collect-garbage) (update-memory-text)]))]
(update-memory-text)]))])) [init-width "99.99 MB"])])
(set! memory-canvases (cons this-frames-memory-canvas memory-canvases)) (set! memory-canvases (cons ec memory-canvases))
(maybe-create-memory-use-timer) (update-memory-text)
(set! memory-cleanup (set! memory-cleanup
(λ () (λ ()
(set! memory-canvases (remq this-frames-memory-canvas memory-canvases)))) (set! memory-canvases (remq ec memory-canvases))))
(send panel stretchable-width #f)) (send panel stretchable-width #f))
(define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)])) (define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)]))
@ -1020,37 +1021,6 @@
(min-client-height (inexact->exact (floor th))))) (min-client-height (inexact->exact (floor th)))))
(update-client-width init-width))) (update-client-width init-width)))
(define memory-canvases '())
(define (update-memory-text)
(for ([memory-canvas (in-list memory-canvases)])
(send memory-canvas update-memory-use)))
(define memory-position-canvas%
(class position-canvas%
(inherit set-str)
(define/public (update-memory-use)
(set! last-memory-use (current-memory-use))
(set-str (format-number last-memory-use)))
(define/public (update-memory-use-if-bigish-change)
(define change-amount (abs (- (current-memory-use) last-memory-use)))
(when (change-amount . > . (* 1024 1024)) ;; more than one meg
(update-memory-use)))
(define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)]
[before-decimal (floor mbytes)]
[after-decimal (modulo (floor (* mbytes 100)) 100)])
(string-append
(number->string before-decimal)
"."
(cond
[(<= after-decimal 9) (format "0~a" after-decimal)]
[else (number->string after-decimal)])
" MB")))
(super-new [init-width "99.99 MB"])
(define last-memory-use 0)
(update-memory-use)))
(define text-info<%> frame:text-info<%>) (define text-info<%> frame:text-info<%>)
(define text-info-mixin (define text-info-mixin
(mixin (info<%>) (text-info<%>) (mixin (info<%>) (text-info<%>)
@ -1539,8 +1509,7 @@
(string-constant no) (string-constant no)
(string-constant are-you-sure-revert-title) (string-constant are-you-sure-revert-title)
#f #f
this this))
#:dialog-mixin focus-table-mixin))
(revert)))) (revert))))
#t)) #t))
@ -2401,11 +2370,7 @@
(define/override (edit-menu:create-find-case-sensitive?) #t) (define/override (edit-menu:create-find-case-sensitive?) #t)
(define/override (edit-menu:replace-all-callback menu evt) (replace-all) #t) (define/override (edit-menu:replace-all-callback menu evt) (replace-all) #t)
(define/override (edit-menu:replace-all-on-demand item) (define/override (edit-menu:replace-all-on-demand item) (send item enable (not hidden?)))
(send item enable (and find-edit
(not (string=? (send find-edit get-text) ""))
(not hidden?)
replace-visible?)))
(define/override (edit-menu:create-replace-all?) #t) (define/override (edit-menu:create-replace-all?) #t)
(define/override make-root-area-container (define/override make-root-area-container
@ -2573,14 +2538,9 @@
(hash-set! ht found-txt #t) (hash-set! ht found-txt #t)
(send found-txt begin-edit-sequence)) (send found-txt begin-edit-sequence))
(let ([start (- found-pos (send find-edit last-position))]) (let ([start (- found-pos (send find-edit last-position))])
(define revision-before (send found-txt get-revision-number))
(send found-txt delete start found-pos) (send found-txt delete start found-pos)
(define revision-after (send found-txt get-revision-number)) (copy-over replace-edit 0 (send replace-edit last-position) found-txt start)
(unless (= revision-before revision-after) (loop found-txt (+ start (send replace-edit last-position)))))))
(copy-over replace-edit 0 (send replace-edit last-position) found-txt start))
(loop found-txt (if (= revision-before revision-after)
found-pos
(+ start (send replace-edit last-position))))))))
(hash-for-each ht (λ (txt _) (send txt end-edit-sequence))))))) (hash-for-each ht (λ (txt _) (send txt end-edit-sequence)))))))
(define/private (pop-all-the-way-out txt) (define/private (pop-all-the-way-out txt)
@ -2787,6 +2747,8 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%))) (define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new))) (super-new)))
(define memory-canvases '())
(define bday-click-canvas% (define bday-click-canvas%
(class canvas% (class canvas%
(define/override (on-event evt) (define/override (on-event evt)

144
gui-lib/framework/private/group.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang scheme/unit
(require string-constants (require string-constants
racket/class racket/class
@ -6,17 +6,8 @@
"../preferences.rkt" "../preferences.rkt"
"../gui-utils.rkt" "../gui-utils.rkt"
mred/mred-sig mred/mred-sig
racket/path racket/path)
racket/unit)
;; for use in the test suite
(define pay-attention-to-current-eventspace-has-standard-menus?
(make-parameter #t))
(provide pay-attention-to-current-eventspace-has-standard-menus?
group@)
(define-unit group@
(import mred^ (import mred^
[prefix application: framework:application^] [prefix application: framework:application^]
[prefix frame: framework:frame^] [prefix frame: framework:frame^]
@ -277,82 +268,79 @@
(or (not (preferences:get 'framework:exit-when-no-frames)) (or (not (preferences:get 'framework:exit-when-no-frames))
(exit:exiting?) (exit:exiting?)
(not (= 1 number-of-frames)) (not (= 1 number-of-frames))
(and (pay-attention-to-current-eventspace-has-standard-menus?) (current-eventspace-has-standard-menus?)
(current-eventspace-has-standard-menus?))
(exit:user-oks-exit)))) (exit:user-oks-exit))))
(define (on-close-action) (define (on-close-action)
(when (preferences:get 'framework:exit-when-no-frames) (when (preferences:get 'framework:exit-when-no-frames)
(unless (exit:exiting?) (unless (exit:exiting?)
(when (and (null? (send (get-the-frame-group) get-frames)) (when (and (null? (send (get-the-frame-group) get-frames))
(not (and (pay-attention-to-current-eventspace-has-standard-menus?) (not (current-eventspace-has-standard-menus?)))
(current-eventspace-has-standard-menus?))))
(exit:exit))))) (exit:exit)))))
(define (choose-a-frame parent) (define (choose-a-frame parent)
(define sorted-frames (letrec-values ([(sorted-frames)
(sort (sort
(send (get-the-frame-group) get-frames) (send (get-the-frame-group) get-frames)
(λ (x y) (string-ci<=? (send x get-label) (send y get-label))))) (λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
(define d [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
(make-object dialog% (string-constant bring-frame-to-front) parent 400 600)) [(lb) (instantiate list-box% ()
(define lb (label #f)
(new list-box% (choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
(label #f) (callback (λ (x y) (listbox-callback y)))
(choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames)) (parent d))]
(callback (λ (x y) (listbox-callback y))) [(t) (instantiate text:hide-caret/selection% ())]
(parent d))) [(ec) (instantiate canvas:basic% ()
(define t (new text:hide-caret/selection%)) (parent d)
(define ec (new canvas:basic% (stretchable-height #f))]
(parent d) [(bp) (instantiate horizontal-panel% ()
(stretchable-height #f))) (parent d)
(define bp (new horizontal-panel% (stretchable-height #f)
(parent d) (alignment '(right center)))]
(stretchable-height #f) [(cancelled?) #t]
(alignment '(right center)))) [(listbox-callback)
(define cancelled? #t) (λ (evt)
(define (listbox-callback evt) (case (send evt get-event-type)
(case (send evt get-event-type) [(list-box)
[(list-box)
(send ok enable (pair? (send lb get-selections))) (send ok enable (pair? (send lb get-selections)))
(let ([full-name (let ([full-name
(let ([sels (send lb get-selections)]) (let ([sels (send lb get-selections)])
(and (pair? sels) (and (pair? sels)
(let ([fr (list-ref sorted-frames (car sels))]) (let ([fr (list-ref sorted-frames (car sels))])
(and (is-a? fr frame:basic%) (and (is-a? fr frame:basic%)
(send fr get-filename)))))]) (send fr get-filename)))))])
(send t begin-edit-sequence) (send t begin-edit-sequence)
(send t erase) (send t erase)
(when full-name (when full-name
(send t insert (path->string full-name))) (send t insert (path->string full-name)))
(send t end-edit-sequence))] (send t end-edit-sequence))]
[(list-box-dclick) [(list-box-dclick)
(set! cancelled? #f) (set! cancelled? #f)
(send d show #f)])) (send d show #f)]))]
(define-values (ok cancel) [(ok cancel)
(gui-utils:ok/cancel-buttons (gui-utils:ok/cancel-buttons
bp bp
(λ (x y) (λ (x y)
(set! cancelled? #f) (set! cancelled? #f)
(send d show #f)) (send d show #f))
(λ (x y) (λ (x y)
(send d show #f)))) (send d show #f)))])
(send ec set-line-count 3) (send ec set-line-count 3)
(send ec set-editor t) (send ec set-editor t)
(send t auto-wrap #t) (send t auto-wrap #t)
(let ([fr (car sorted-frames)]) (let ([fr (car sorted-frames)])
(when (and (is-a? fr frame:basic<%>) (when (and (is-a? fr frame:basic<%>)
(send fr get-filename)) (send fr get-filename))
(send t insert (path->string (send (car sorted-frames) get-filename)))) (send t insert (path->string (send (car sorted-frames) get-filename))))
(send lb set-selection 0)) (send lb set-selection 0))
(send d show #t) (send d show #t)
(unless cancelled? (unless cancelled?
(let ([sels (send lb get-selections)]) (let ([sels (send lb get-selections)])
(unless (null? sels) (unless (null? sels)
(send (list-ref sorted-frames (car sels)) show #t))))) (send (list-ref sorted-frames (car sels)) show #t))))))
(define (internal-get-the-frame-group) (define (internal-get-the-frame-group)
(let ([the-frame-group (make-object %)]) (let ([the-frame-group (make-object %)])
@ -360,4 +348,4 @@
(internal-get-the-frame-group))) (internal-get-the-frame-group)))
(define (get-the-frame-group) (define (get-the-frame-group)
(internal-get-the-frame-group))) (internal-get-the-frame-group))

21
gui-lib/framework/private/main.rkt
View File

@ -25,12 +25,6 @@
(application-preferences-handler (λ () (preferences:show-dialog))) (application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:editor-x-selection-mode #t boolean?)
(when (equal? (system-type) 'unix)
(preferences:add-callback
'framework:editor-x-selection-mode
(λ (p v) (editor-set-x-selection-mode v))))
(preferences:set-default 'framework:ascii-art-enlarge #f boolean?) (preferences:set-default 'framework:ascii-art-enlarge #f boolean?)
(preferences:set-default 'framework:color-scheme 'classic symbol?) (preferences:set-default 'framework:color-scheme 'classic symbol?)
@ -559,12 +553,21 @@
(preferences:set-default 'framework:coloring-active #t boolean?) (preferences:set-default 'framework:coloring-active #t boolean?)
(color-prefs:add-color-scheme-entry 'framework:default-text-color "black" "white") (color-prefs:add-color-scheme-entry 'framework:default-text-color "black" "white")
(color-prefs:register-color-scheme-entry-change-callback
'framework:basic-canvas-background
(λ (v)
(editor:set-default-font-color
(color-prefs:lookup-in-color-scheme 'framework:default-text-color)
v)))
(color-prefs:register-color-scheme-entry-change-callback (color-prefs:register-color-scheme-entry-change-callback
'framework:default-text-color 'framework:default-text-color
(λ (v) (λ (v)
(editor:set-default-font-color v))) (editor:set-default-font-color
(editor:set-default-font-color v
(color-prefs:lookup-in-color-scheme 'framework:default-text-color)) (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))))
(editor:set-default-font-color
(color-prefs:lookup-in-color-scheme 'framework:default-text-color)
(color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
(color-prefs:add-color-scheme-entry 'framework:misspelled-text-color "black" "white") (color-prefs:add-color-scheme-entry 'framework:misspelled-text-color "black" "white")

7
gui-lib/framework/private/number-snip.rkt
View File

@ -8,7 +8,7 @@
file/convertible) file/convertible)
(import mred^) (import mred^)
(export (rename framework:number-snip/int^ (export (rename framework:number-snip^
[-snip-class% snip-class%])) [-snip-class% snip-class%]))
(init-depend mred^) (init-depend mred^)
@ -91,10 +91,7 @@
[(text) [(text)
(send number-snip get-text 0 1)] (send number-snip get-text 0 1)]
[else default]))]))) [else default]))])))
(define (get-number s) (send s get-number))
(define (is-number-snip? x) (is-a? x number-snip%))
(define number-snip% (define number-snip%
(class* snip% (readable-snip<%> number-snip-convertible<%>) (class* snip% (readable-snip<%> number-snip-convertible<%>)
;; number : number ;; number : number

5
gui-lib/framework/private/preferences.rkt
View File

@ -511,11 +511,6 @@ the state transitions / contracts are:
'framework:column-guide-width 'framework:column-guide-width
(string-constant maximum-char-width-guide-pref-check-box) (string-constant maximum-char-width-guide-pref-check-box)
(λ (n) (and (exact-integer? n) (>= n 2)))) (λ (n) (and (exact-integer? n) (>= n 2))))
(when (equal? (system-type) 'unix)
(add-check editor-panel
'framework:editor-x-selection-mode
(string-constant editor-x-selection-mode)))
(editor-panel-procs editor-panel))))]) (editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel))) (add-editor-checkbox-panel)))

49
gui-lib/framework/private/racket.rkt
View File

@ -475,7 +475,7 @@
position-location get-dc) position-location get-dc)
(define private-racket-container-keymap (new keymap:aug-keymap%)) (define private-racket-container-keymap (new keymap:aug-keymap%))
(define/public (get-private-racket-container-keymap) private-racket-container-keymap) (define/public (get-private-racket-container-keymap) private-racket-container-keymap)
(define/override (get-keymaps) (define/override (get-keymaps)
(editor:add-after-user-keymap private-racket-container-keymap (editor:add-after-user-keymap private-racket-container-keymap
@ -1350,11 +1350,19 @@
(send text end-edit-sequence)) (send text end-edit-sequence))
(define tabify-pref (preferences:get 'framework:tabify)) (define tabify-pref (preferences:get 'framework:tabify))
(define tabify-pref-callback (lambda (k v) (set! tabify-pref v)))
(preferences:add-callback (preferences:add-callback
'framework:tabify 'framework:tabify
tabify-pref-callback (lambda (k v) (set! tabify-pref v)))
#t) (define/private (racket-lexer-wrapper in offset mode)
(define-values (lexeme type paren start end backup-delta new-mode)
(module-lexer/waived in offset mode))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme tabify-pref))
(values lexeme 'keyword paren start end backup-delta new-mode)]
[else
(values lexeme type paren start end backup-delta new-mode)]))
(define/override (put-file text sup directory default-name) (define/override (put-file text sup directory default-name)
;; don't call the surrogate's super, since it sets the default extension ;; don't call the surrogate's super, since it sets the default extension
@ -1363,42 +1371,13 @@
(parameterize ([finder:default-extension "rkt"]) (parameterize ([finder:default-extension "rkt"])
(sup directory default-name))] (sup directory default-name))]
[else (sup directory default-name)])) [else (sup directory default-name)]))
(define/override (set-get-token get-token-) (super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
(super set-get-token (wrap-get-token get-token- (λ () tabify-pref))))
(super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref)))
(token-sym->style short-sym->style-name) (token-sym->style short-sym->style-name)
(matches '((|(| |)|) (matches '((|(| |)|)
(|[| |]|) (|[| |]|)
(|{| |}|)))))) (|{| |}|))))))
(define (wrap-get-token get-token- get-tabify-pref)
(define wrapped-get-token
(cond
[(procedure-arity-includes? get-token- 3)
(λ (in offset mode)
(define-values (lexeme type paren start end backup-delta new-mode)
(get-token- in offset mode))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
(values lexeme 'keyword paren start end backup-delta new-mode)]
[else
(values lexeme type paren start end backup-delta new-mode)]))]
[else
(λ (in)
(define-values (lexeme type paren start end) (get-token- in))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
(values lexeme 'keyword paren start end)]
[else
(values lexeme type paren start end)]))]))
wrapped-get-token)
;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp) ;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp)
;; -> (or/c #f 'lambda 'define 'begin 'for/fold) ;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-head-sexp-type-from-prefs text pref) (define (get-head-sexp-type-from-prefs text pref)

6
gui-lib/framework/private/sig.rkt
View File

@ -9,11 +9,7 @@
(snip-class%)) (snip-class%))
(define-signature number-snip^ extends number-snip-class^ (define-signature number-snip^ extends number-snip-class^
(make-repeating-decimal-snip (make-repeating-decimal-snip
make-fraction-snip make-fraction-snip))
is-number-snip?
get-number))
(define-signature number-snip/int^ extends number-snip^
())
(define-signature comment-box-class^ (define-signature comment-box-class^
(snip%)) (snip%))

152
gui-lib/framework/private/text.rkt
View File

@ -530,7 +530,7 @@
delete find-snip delete find-snip
get-style-list change-style get-style-list change-style
position-line line-start-position position-line line-start-position
get-filename get-end-position) get-filename)
(define/public (get-fixed-style) (define/public (get-fixed-style)
(send (get-style-list) find-named-style "Standard")) (send (get-style-list) find-named-style "Standard"))
@ -585,80 +585,29 @@
(define/augment (after-delete start len) (define/augment (after-delete start len)
(set! edition (+ edition 1)) (set! edition (+ edition 1))
(inner (void) after-delete start len)) (inner (void) after-delete start len))
(define/public (move-to dest-edit start end dest-position)
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
(error 'move-to
"expected start, end, and dest-pos to be non-negative"))
(when (> start end)
(error 'move-to
"expected start position smaller than end position"))
(define (release-or-copy snip)
(cond
[(send snip release-from-owner) snip]
[else
(define copy (send snip copy))
(define snip-start (get-snip-position snip))
(define snip-end (+ snip-start (send snip get-count)))
(delete snip-start snip-end)
copy]))
(define move-to-self? (object=? this dest-edit))
(unless (or (= start end) (and move-to-self? (<= start dest-position end)))
(let loop ([current-start start]
[current-end (min end (get-end-position))]
[current-dest dest-position])
(split-snip current-start)
(split-snip current-end)
(define snip (find-snip current-end 'before-or-none))
(cond
[(or (not snip) (< (get-snip-position snip) current-start)) (void)]
[else
(define released/copied (release-or-copy snip))
(define snip-count (send released/copied get-count))
(define new-start
(cond
[(or (not move-to-self?) (> current-dest current-start)) current-start]
[else (+ current-start snip-count)]))
(define new-end
(cond
[(and move-to-self? (< current-dest current-end)) current-end]
[else (- current-end snip-count)]))
(define new-dest
(cond
[(or (not move-to-self?) (< current-dest current-start)) current-dest]
[else (- current-dest snip-count)]))
(send dest-edit insert released/copied new-dest new-dest)
(loop new-start new-end new-dest)]))))
(define/public (copy-to dest-edit start end dest-position)
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
(error 'copy-to
"expected start, end, and dest-pos to be non-negative"))
(when (> start end)
(error 'copy-to
"expected start position smaller than end position"))
(unless (= start end)
(split-snip start)
(split-snip end)
(define snips
(let loop ([snip (find-snip end 'before)] [snips '()])
(cond
[(or (not snip) (< (get-snip-position snip) start)) (reverse snips)]
[else (loop (send snip previous) (cons (send snip copy) snips))])))
(for ([snip (in-list snips)])
(send dest-edit insert snip dest-position dest-position))))
(define/public (move/copy-to-edit dest-edit start end dest-position (define/public (move/copy-to-edit dest-edit start end dest-position
#:try-to-move? [try-to-move? #t]) #:try-to-move? [try-to-move? #t])
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position)) (split-snip start)
(error 'move/copy-to-edit (split-snip end)
"expected start, end, and dest-pos to be non-negative")) (let loop ([snip (find-snip end 'before)])
(when (> start end) (cond
(error 'move/copy-to-edit [(or (not snip) (< (get-snip-position snip) start))
"expected start position smaller than end position")) (void)]
(cond [else
[try-to-move? (move-to dest-edit start end dest-position)] (let ([prev (send snip previous)]
[else (copy-to dest-edit start end dest-position)])) [released/copied
(if try-to-move?
(if (send snip release-from-owner)
snip
(let* ([copy (send snip copy)]
[snip-start (get-snip-position snip)]
[snip-end (+ snip-start (send snip get-count))])
(delete snip-start snip-end)
snip))
(send snip copy))])
(send dest-edit insert released/copied dest-position dest-position)
(loop prev))])))
(public initial-autowrap-bitmap) (public initial-autowrap-bitmap)
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap)) (define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
@ -2305,8 +2254,7 @@
(gui-utils:get-choice (gui-utils:get-choice
(string-constant save-as-plain-text) (string-constant save-as-plain-text)
(string-constant yes) (string-constant yes)
(string-constant no) (string-constant no))))
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'text)] (set-file-format 'text)]
[(and (not all-strings?) [(and (not all-strings?)
(eq? format 'same) (eq? format 'same)
@ -2315,8 +2263,7 @@
(gui-utils:get-choice (gui-utils:get-choice
(string-constant save-in-drs-format) (string-constant save-in-drs-format)
(string-constant yes) (string-constant yes)
(string-constant no) (string-constant no))))
#:dialog-mixin frame:focus-table-mixin)))
(set-file-format 'standard)] (set-file-format 'standard)]
[else (void)])) [else (void)]))
(inner (void) on-save-file name format)) (inner (void) on-save-file name format))
@ -3056,12 +3003,7 @@
(cond (cond
[(= start end) (flush-proc)] [(= start end) (flush-proc)]
[else [else
(define pair (cons (if (and (= start 0) (define pair (cons (subbytes to-write start end) style))
(= end (bytes-length to-write))
(immutable? to-write))
to-write
(subbytes to-write start end))
style))
(cond (cond
[(eq? (current-thread) (eventspace-handler-thread eventspace)) [(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-channel (make-channel)) (define return-channel (make-channel))
@ -3373,7 +3315,7 @@
[(potential-commits new-commit-response-evts) [(potential-commits new-commit-response-evts)
(separate (separate
committers committers
(service-committer (at-queue-size data) peeker-evt))]) (service-committer data peeker-evt))])
(when (and on-peek (when (and on-peek
(not (null? not-ready-peekers))) (not (null? not-ready-peekers)))
(parameterize ([current-eventspace eventspace]) (parameterize ([current-eventspace eventspace])
@ -3396,7 +3338,7 @@
(handle-evt (handle-evt
read-chan read-chan
(λ (ent) (λ (ent)
(at-enqueue! ent data) (set! data (at-enqueue ent data))
(unless position (unless position
(set! position (cdr ent))) (set! position (cdr ent)))
(loop))) (loop)))
@ -3496,22 +3438,23 @@
;; service-committer : queue evt -> committer -> (union #f evt) ;; service-committer : queue evt -> committer -> (union #f evt)
;; if the committer can be dumped, return an evt that ;; if the committer can be dumped, return an evt that
;; does the dumping. otherwise, return #f ;; does the dumping. otherwise, return #f
(define ((service-committer size peeker-evt) a-committer) (define ((service-committer data peeker-evt) a-committer)
(match a-committer (match a-committer
[(struct committer [(struct committer
(kr commit-peeker-evt (kr commit-peeker-evt
done-evt resp-chan resp-nack)) done-evt resp-chan resp-nack))
(cond (let ([size (at-queue-size data)])
[(not (eq? peeker-evt commit-peeker-evt)) (cond
(choice-evt [(not (eq? peeker-evt commit-peeker-evt))
resp-nack (choice-evt
(channel-put-evt resp-chan #f))] resp-nack
[(< size kr) (channel-put-evt resp-chan #f))]
(choice-evt [(< size kr)
resp-nack (choice-evt
(channel-put-evt resp-chan 'commit-failure))] resp-nack
[else ;; commit succeeds (channel-put-evt resp-chan 'commit-failure))]
#f])])) [else ;; commit succeeds
#f]))]))
;; service-waiter : peeker -> (union #f evt) ;; service-waiter : peeker -> (union #f evt)
;; if the peeker can be serviced, build an event to service it ;; if the peeker can be serviced, build an event to service it
@ -4485,15 +4428,7 @@ designates the character that triggers autocompletion
show-line-numbers?) show-line-numbers?)
(define/public (set-line-numbers-color color) (define/public (set-line-numbers-color color)
(define new-line-numbers-color (set! line-numbers-color color))
(cond
[(string? color) (send the-color-database find-color color)]
[(is-a? color color%) color]
[else
(raise-argument-error 'line-numbers-mixin::set-line-numbers-color
(format "~s" '(or/c string? (is-a?/c color%)))
color)]))
(set! line-numbers-color new-line-numbers-color))
(define notify-registered-in-list #f) (define notify-registered-in-list #f)
@ -4539,7 +4474,9 @@ designates the character that triggers autocompletion
(send dc set-text-mode (saved-dc-state-text-mode dc-state))) (send dc set-text-mode (saved-dc-state-text-mode dc-state)))
(define/private (get-foreground) (define/private (get-foreground)
(or line-numbers-color (get-style-foreground))) (if line-numbers-color
(make-object color% line-numbers-color)
(get-style-foreground)))
;; set the dc stuff to values we want ;; set the dc stuff to values we want
(define/private (setup-dc dc) (define/private (setup-dc dc)
@ -4988,9 +4925,6 @@ designates the character that triggers autocompletion
(cons e (at-queue-front q)) (cons e (at-queue-front q))
(at-queue-back q) (at-queue-back q)
(+ (at-queue-count q) 1))) (+ (at-queue-count q) 1)))
(define (at-enqueue! e q)
(set-at-queue-front! q (cons e (at-queue-front q)))
(set-at-queue-count! q (+ (at-queue-count q) 1)))
(define (at-queue-first q) (define (at-queue-first q)
(at-flip-around q) (at-flip-around q)
(let ([back (at-queue-back q)]) (let ([back (at-queue-back q)])

2
gui-lib/framework/test.rkt
View File

@ -1024,7 +1024,7 @@
@method[canvas<%> on-event] method. @method[canvas<%> on-event] method.
Use @racket[test:button-push] to click on a button. Use @racket[test:button-push] to click on a button.
Under Mac OS, @racket['right] corresponds to holding down the command Under Mac OS X, @racket['right] corresponds to holding down the command
modifier key while clicking and @racket['middle] cannot be generated. modifier key while clicking and @racket['middle] cannot be generated.
Under Windows, @racket['middle] can only be generated if the user has a Under Windows, @racket['middle] can only be generated if the user has a

4
gui-lib/info.rkt
View File

@ -12,7 +12,7 @@
"pict-lib" "pict-lib"
"scheme-lib" "scheme-lib"
"scribble-lib" "scribble-lib"
["string-constants-lib" #:version "1.14"] ["string-constants-lib" #:version "1.9"]
"option-contract-lib" "option-contract-lib"
"2d-lib" "2d-lib"
"compatibility-lib" "compatibility-lib"
@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby)) (define pkg-authors '(mflatt robby))
(define version "1.30") (define version "1.28")

13
gui-lib/mred/installer.rkt
View File

@ -26,9 +26,7 @@
(for ([v variants] #:when (memq v '(3m cgc))) (for ([v variants] #:when (memq v '(3m cgc)))
(parameterize ([current-launcher-variant v]) (parameterize ([current-launcher-variant v])
(create-embedding-executable (create-embedding-executable
(prep-dir (mred-program-launcher-path "MrEd" (prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
#:user? user?
#:tethered? tethered?))
#:cmdline (append #:cmdline (append
(if tethered? (if user? (addon-flags) (config-flags)) null) (if tethered? (if user? (addon-flags) (config-flags)) null)
'("-I" "scheme/gui/init")) '("-I" "scheme/gui/init"))
@ -45,10 +43,7 @@
(make-gracket-launcher (make-gracket-launcher
#:tether-mode tether-mode #:tether-mode tether-mode
'("-I" "scheme/gui/init" "-z") '("-I" "scheme/gui/init" "-z")
(prep-dir (mred-program-launcher-path "mred-text" (prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
#:user? user?
#:tethered? tethered?
#:console? #t))
`([relative? . ,(not (or user? tethered?))] `([relative? . ,(not (or user? tethered?))]
[subsystem . console] [subsystem . console]
[single-instance? . #f])))))) [single-instance? . #f]))))))
@ -59,9 +54,7 @@
(make-gracket-launcher (make-gracket-launcher
#:tether-mode tether-mode #:tether-mode tether-mode
null null
(prep-dir (mred-program-launcher-path "MrEd" (prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
#:user? user?
#:tethered? tethered?))
`([exe-name . "GRacket"] `([exe-name . "GRacket"]
[relative? . ,(not (or user? tethered?))] [relative? . ,(not (or user? tethered?))]
[exe-is-gracket . #t])))))) [exe-is-gracket . #t]))))))

4
gui-lib/mred/private/wx/cocoa/key-translate.rkt
View File

@ -400,9 +400,9 @@
(define-unicode-key kOptionUnicode #x2325) ;/* Unicode OPTION KEY*/ (define-unicode-key kOptionUnicode #x2325) ;/* Unicode OPTION KEY*/
(define-unicode-key kCommandUnicode #x2318) ;/* Unicode PLACE OF INTEREST SIGN*/ (define-unicode-key kCommandUnicode #x2318) ;/* Unicode PLACE OF INTEREST SIGN*/
(define-unicode-key kPencilUnicode #x270E) ;/* Unicode LOWER RIGHT PENCIL; (define-unicode-key kPencilUnicode #x270E) ;/* Unicode LOWER RIGHT PENCIL;
; actually pointed left until Mac OS 10.3*/ ; actually pointed left until Mac OS X 10.3*/
(define-unicode-key kPencilLeftUnicode #xF802) ;/* Unicode LOWER LEFT PENCIL; (define-unicode-key kPencilLeftUnicode #xF802) ;/* Unicode LOWER LEFT PENCIL;
; available in Mac OS 10.3 and later*/ ; available in Mac OS X 10.3 and later*/
(define-unicode-key kCheckUnicode #x2713) ;/* Unicode CHECK MARK*/ (define-unicode-key kCheckUnicode #x2713) ;/* Unicode CHECK MARK*/
(define-unicode-key kDiamondUnicode #x25C6) ;/* Unicode BLACK DIAMOND*/ (define-unicode-key kDiamondUnicode #x25C6) ;/* Unicode BLACK DIAMOND*/
(define-unicode-key kBulletUnicode #x2022) ;/* Unicode BULLET*/ (define-unicode-key kBulletUnicode #x2022) ;/* Unicode BULLET*/

3
gui-lib/mred/private/wx/cocoa/queue.rkt
View File

@ -34,6 +34,7 @@
yield) yield)
(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) (import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray)
(import-protocol NSApplicationDelegate)
;; Extreme hackery to hide original arguments from ;; Extreme hackery to hide original arguments from
;; NSApplication, because NSApplication wants to turn ;; NSApplication, because NSApplication wants to turn
@ -51,7 +52,7 @@
(define got-file? #f) (define got-file? #f)
(define-objc-class RacketApplicationDelegate NSObject ;; note: NSApplicationDelegate doesn't exist at run time (define-objc-class RacketApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
[] []
[-a _NSUInteger (applicationShouldTerminate: [_id app]) [-a _NSUInteger (applicationShouldTerminate: [_id app])
(queue-quit-event) (queue-quit-event)

3
gui-lib/mred/private/wx/cocoa/slider.rkt
View File

@ -164,8 +164,7 @@
(flip (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue))))) (flip (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue)))))
(define/public (update-message [val (get-value)]) (define/public (update-message [val (get-value)])
(tellv message-cocoa setStringValue: #:type _NSString (format "~a" val)) (tellv message-cocoa setStringValue: #:type _NSString (format "~a" val)))
(tellv message-cocoa sizeToFit))
(inherit get-cocoa-window) (inherit get-cocoa-window)
(define/override (post-mouse-down) (define/override (post-mouse-down)

2
gui-lib/mred/private/wx/common/backing-dc.rkt
View File

@ -124,7 +124,7 @@
(let ([w (box 0)] (let ([w (box 0)]
[h (box 0)]) [h (box 0)])
(get-backing-size w h) (get-backing-size w h)
(let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap (max 1 w) (max 1 h))) (unbox w) (unbox h))]) (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))])
(internal-set-bitmap bm #t)) (internal-set-bitmap bm #t))
(let ([cr (super get-cr)]) (let ([cr (super get-cr)])
(set! retained-cr cr) (set! retained-cr cr)

3
gui-lib/mred/private/wx/gtk/canvas.rkt
View File

@ -17,7 +17,6 @@
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"window.rkt" "window.rkt"
"queue.rkt"
"client-window.rkt" "client-window.rkt"
"widget.rkt" "widget.rkt"
"dc.rkt" "dc.rkt"
@ -614,7 +613,7 @@
;; A transparent canvas can't have a native window, so we ;; A transparent canvas can't have a native window, so we
;; need to release any freezes befre the window implementation ;; need to release any freezes befre the window implementation
;; might change. ;; might change.
(when (or transparentish? wayland?) (unrealize))) (when transparentish? (unrealize)))
(define/public (begin-refresh-sequence) (define/public (begin-refresh-sequence)
(send dc suspend-flush)) (send dc suspend-flush))

2
gui-lib/mred/private/wx/gtk/cursor.rkt
View File

@ -36,7 +36,7 @@
(cons 'blank void) (cons 'blank void)
(cons 'hand GDK_HAND2)))) (cons 'hand GDK_HAND2))))
(define _GdkCursor (_cpointer/null 'GdkCursor)) (define _GdkCursor (_cpointer 'GdkCursor))
(define-gdk gdk_cursor_new (_fun _int -> _GdkCursor)) (define-gdk gdk_cursor_new (_fun _int -> _GdkCursor))
(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) (define-gdk gdk_display_get_default (_fun -> _GdkDisplay))
(define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor)) (define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor))

3
gui-lib/mred/private/wx/gtk/dc.rkt
View File

@ -4,7 +4,6 @@
racket/class racket/class
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"queue.rkt"
"window.rkt" "window.rkt"
"frame.rkt" "frame.rkt"
"x11.rkt" "x11.rkt"
@ -196,11 +195,9 @@
(define/override (make-backing-bitmap w h) (define/override (make-backing-bitmap w h)
(cond (cond
[(and (not is-transparentish?) [(and (not is-transparentish?)
(not wayland?)
(eq? 'unix (system-type))) (eq? 'unix (system-type)))
(make-object x11-bitmap% w h (send canvas get-client-gtk))] (make-object x11-bitmap% w h (send canvas get-client-gtk))]
[(and (not is-transparentish?) [(and (not is-transparentish?)
(not wayland?)
(eq? 'windows (system-type))) (eq? 'windows (system-type)))
(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
[else [else

28
gui-lib/mred/private/wx/gtk/frame.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/define
racket/class racket/class
racket/promise racket/promise
racket/runtime-path racket/runtime-path
@ -17,7 +16,6 @@
"cursor.rkt" "cursor.rkt"
"pixbuf.rkt" "pixbuf.rkt"
"resolution.rkt" "resolution.rkt"
"queue.rkt"
"../common/queue.rkt") "../common/queue.rkt")
(provide (provide
@ -90,10 +88,6 @@
[max_aspect _double] [max_aspect _double]
[win_gravity _int])) [win_gravity _int]))
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void)) (define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
(define-gtk gtk_widget_get_allocated_width (_fun _GtkWidget -> _int)
#:make-fail make-not-available)
(define-gtk gtk_widget_get_allocated_height (_fun _GtkWidget -> _int)
#:make-fail make-not-available)
(define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget)) (define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget))
(define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void)) (define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void))
@ -113,15 +107,11 @@
(lambda (gtk a) (lambda (gtk a)
(let ([wx (gtk->wx gtk)]) (let ([wx (gtk->wx gtk)])
(when wx (when wx
(define-values (w h) (if gtk3?
(gtk_window_get_size gtk)
(values (GdkEventConfigure-width a)
(GdkEventConfigure-height a))))
(send wx remember-size (send wx remember-size
(->normal (GdkEventConfigure-x a)) (->normal (GdkEventConfigure-x a))
(->normal (GdkEventConfigure-y a)) (->normal (GdkEventConfigure-y a))
(->normal w) (->normal (GdkEventConfigure-width a))
(->normal h)))) (->normal (GdkEventConfigure-height a)))))
#f)) #f))
(define-cstruct _GdkEventWindowState ([type _int] (define-cstruct _GdkEventWindowState ([type _int]
@ -247,9 +237,6 @@
(define/override (set-child-size child-gtk x y w h) (define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y)) (gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y))
;; gtk3: we expect a panel in a frame to be always visible, so
;; this size request should work
(avoid-preferred-size-warning child-gtk)
(gtk_widget_set_size_request child-gtk (->screen w) (->screen h))) (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))
(define/public (on-close) #t) (define/public (on-close) #t)
@ -277,18 +264,9 @@
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
(define (to-max v) (if (= v -1) #x3FFFFF (->screen v))) (define (to-max v) (if (= v -1) #x3FFFFF (->screen v)))
(set! saved-enforcements (vector min-x min-y max-x max-y)) (set! saved-enforcements (vector min-x min-y max-x max-y))
(define-values (dx dy)
(if wayland?
;; Hints work at a layer of geometry below some offset that
;; `gtk_window_get_size` works but above where allocations
;; work:
(let-values ([(w h) (gtk_window_get_size gtk)])
(values (- (gtk_widget_get_allocated_width gtk) w)
(- (gtk_widget_get_allocated_height gtk) h)))
(values 0 0)))
(gtk_window_set_geometry_hints gtk gtk (gtk_window_set_geometry_hints gtk gtk
(make-GdkGeometry (->screen min-x) (->screen min-y) (make-GdkGeometry (->screen min-x) (->screen min-y)
(+ dx (to-max max-x)) (+ dy (to-max max-y)) (to-max max-x) (to-max max-y)
0 0 0 0
(->screen inc-x) (->screen inc-y) (->screen inc-x) (->screen inc-y)
0.0 0.0 0.0 0.0

117
gui-lib/mred/private/wx/gtk/gcwin.rkt
View File

@ -6,7 +6,6 @@
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"window.rkt" "window.rkt"
"queue.rkt"
"pixbuf.rkt" "pixbuf.rkt"
"x11.rkt") "x11.rkt")
@ -20,7 +19,7 @@
bitmap->gc-bitmap)) bitmap->gc-bitmap))
;; Gtk2, only: ;; Gtk2, only:
(define-cstruct _GdkWindowAttr2 (define-cstruct _GdkWindowAttr
([title _string] ([title _string]
[event_mask _int] [event_mask _int]
[x _int] [x _int]
@ -37,29 +36,6 @@
[override_redirect _gboolean] [override_redirect _gboolean]
[type_hint _int])) [type_hint _int]))
;; Gtk3, only:
(define-cstruct _GdkWindowAttr3
([title _string]
[event_mask _int]
[x _int]
[y _int]
[width _int]
[height _int]
[wclass _int] ; GDK_INPUT_OUTPUT
[visual _pointer]
[window_type _int] ; GDK_WINDOW_CHILD
[cursor _pointer]
[wmclass_name _string]
[wmclass_class _string]
[override_redirect _gboolean]
[type_hint _int]))
(define make-GdkWindowAttr
(if gtk3?
(lambda (t e x y w h wc vis cm wt c wmc_n wmc_c o th)
(make-GdkWindowAttr3 t e x y w h wc vis wt c wmc_n wmc_c o th))
make-GdkWindowAttr2))
(define << arithmetic-shift) (define << arithmetic-shift)
(define GDK_WA_TITLE (1 . << . 1)) (define GDK_WA_TITLE (1 . << . 1))
@ -76,19 +52,12 @@
(define GDK_WINDOW_CHILD 2) (define GDK_WINDOW_CHILD 2)
(define-gdk gdk_window_new (_fun _GdkWindow (define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint -> _GdkWindow))
(if gtk3?
_GdkWindowAttr3-pointer
_GdkWindowAttr2-pointer)
_uint -> _GdkWindow))
(define-gdk gdk_window_show-p _fpointer (define-gdk gdk_window_show _fpointer)
#:c-id gdk_window_show)
(define-gdk gdk_window_hide _fpointer) (define-gdk gdk_window_hide _fpointer)
(define-gdk gdk_display_flush _fpointer) (define-gdk gdk_display_flush _fpointer)
(define-gdk gdk_window_show (_fun _GdkWindow -> _void))
;; Gtk2 ;; Gtk2
(define-gdk gdk_draw_pixbuf _fpointer (define-gdk gdk_draw_pixbuf _fpointer
#:make-fail make-not-available) #:make-fail make-not-available)
@ -100,11 +69,9 @@
(define-x11 XMapRaised _fpointer #:fail (lambda () #f)) (define-x11 XMapRaised _fpointer #:fail (lambda () #f))
(define-x11 XUnmapWindow _fpointer #:fail (lambda () #f)) (define-x11 XUnmapWindow _fpointer #:fail (lambda () #f))
(define use-x11? (and gtk3? (not wayland?)))
(define (bitmap->gc-bitmap bm client-gtk) (define (bitmap->gc-bitmap bm client-gtk)
(cond (cond
[use-x11? [gtk3?
; Generate an X11 Pixmap ; Generate an X11 Pixmap
(define gwin (widget-window client-gtk)) (define gwin (widget-window client-gtk))
(define display (gdk_x11_display_get_xdisplay (gdk_window_get_display gwin))) (define display (gdk_x11_display_get_xdisplay (gdk_window_get_display gwin)))
@ -142,7 +109,7 @@
(define (create-gc-window client-gtk x y w h) (define (create-gc-window client-gtk x y w h)
(define cwin (widget-window client-gtk)) (define cwin (widget-window client-gtk))
(cond (cond
[use-x11? [gtk3?
;; Work at the level of X11 to change the screen without an event loop ;; Work at the level of X11 to change the screen without an event loop
(define display (gdk_x11_display_get_xdisplay (gdk_window_get_display cwin))) (define display (gdk_x11_display_get_xdisplay (gdk_window_get_display cwin)))
(define s (gtk_widget_get_scale_factor client-gtk)) (define s (gtk_widget_get_scale_factor client-gtk))
@ -165,61 +132,51 @@
(define (free-gc-window win) (define (free-gc-window win)
(cond (cond
[use-x11? (XDestroyWindow (car win) (cdr win))] [gtk3? (XDestroyWindow (car win) (cdr win))]
[else (g_object_unref win)])) [else (g_object_unref win)]))
(define (make-draw win gc-bitmap w h) (define (make-draw win gc-bitmap w h)
(cond (cond
[use-x11? (vector [gtk3? (vector 'ptr_ptr_ptr->void
(vector 'ptr_ptr_ptr->void XSetWindowBackgroundPixmap
XSetWindowBackgroundPixmap (car win)
(car win) (cdr win)
(cdr win) gc-bitmap)]
gc-bitmap))] [else (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
[gtk3? (vector)] gdk_draw_pixbuf
[else (vector win #f gc-bitmap
(vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void 0 0 0 0 w h
gdk_draw_pixbuf 0 0 0)]))
win #f gc-bitmap
0 0 0 0 w h
0 0 0))]))
(define (make-flush) (define (make-flush)
(vector (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))
(vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f)))
(define (vector* . l)
(for*/vector ([v (in-list l)] [e (in-vector v)]) e))
(define (make-gc-show-desc win gc-bitmap w h) (define (make-gc-show-desc win gc-bitmap w h)
(cond (cond
[use-x11? (vector* [gtk3? (vector
(make-draw win gc-bitmap w h) (make-draw win gc-bitmap w h)
(vector (vector 'ptr_ptr_ptr->void
(vector 'ptr_ptr_ptr->void XMapRaised
XMapRaised (car win)
(car win) (cdr win)
(cdr win) #f)
#f)) (make-flush))]
(make-flush))] [else (vector
[else (vector* (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
(vector
(vector 'ptr_ptr_ptr->void gdk_window_show-p win #f #f))
(make-draw win gc-bitmap w h) (make-draw win gc-bitmap w h)
(make-flush))])) (make-flush))]))
(define (make-gc-hide-desc win gc-bitmap w h) (define (make-gc-hide-desc win gc-bitmap w h)
(vector* (vector
;; draw the ``off'' bitmap so we can flush immediately ;; draw the ``off'' bitmap so we can flush immediately
(make-draw win gc-bitmap w h) (make-draw win gc-bitmap w h)
(make-flush) (make-flush)
(vector ;; hide the window; it may take a while for the underlying canvas
;; hide the window; it may take a while for the underlying canvas ;; to refresh:
;; to refresh: (if gtk3?
(if use-x11? (vector 'ptr_ptr_ptr->void
(vector 'ptr_ptr_ptr->void XUnmapWindow
XUnmapWindow (car win)
(car win) (cast (cdr win) _Window _pointer)
(cast (cdr win) _Window _pointer) #f)
#f) (vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f))))
(vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f)))))

12
gui-lib/mred/private/wx/gtk/item.rkt
View File

@ -26,14 +26,10 @@
(when font (when font
(let* ([target-size (let* ([target-size
(cond (cond
[(and gtk3? [gtk3?
((gtk_get_minor_version) . < . 22)) ;; Gtk3 ignores the "size-in-pixels" part of a
;; Prior to version 3.22, GTK+3 ignores the ;; font spec, so we have to adjust the text size
;; "size-in-pixels" part of a font spec, so we have to ;; to compensate.
;; adjust the text size to compensate.
;; With 3.22 and later, a size in points is effectively
;; rounded to an integer absolute size; the `get-control-font-size`
;; function takes that rounding into account.
(* (send font get-size) (* (send font get-size)
(/ 72.0 (/ 72.0
(pango_cairo_font_map_get_resolution (pango_cairo_font_map_get_resolution

14
gui-lib/mred/private/wx/gtk/panel.rkt
View File

@ -28,7 +28,6 @@
(define-gtk gtk_event_box_set_visible_window (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_event_box_set_visible_window (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) (define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_widget_get_visible (_fun _GtkWidget -> _gboolean))
(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void)) (define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void))
@ -138,16 +137,7 @@
(super-new) (super-new)
(define/override (set-child-size child-gtk x y w h) (define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move (get-container-gtk) child-gtk (->screen x) (->screen y)) (gtk_fixed_move (get-container-gtk) child-gtk (->screen x) (->screen y))
(define re-hide? (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))))
(and gtk3?
(not (gtk_widget_get_visible child-gtk))
(begin
(gtk_widget_show child-gtk)
#t)))
(avoid-preferred-size-warning child-gtk)
(gtk_widget_set_size_request child-gtk (->screen w) (->screen h))
(when re-hide?
(gtk_widget_hide child-gtk)))))
(define panel% (define panel%
(class (panel-container-mixin (panel-mixin window%)) (class (panel-container-mixin (panel-mixin window%))
@ -200,7 +190,7 @@
(set-size 0 0 (if border-gtk 3 1) (if border-gtk 3 1)) (set-size 0 0 (if border-gtk 3 1) (if border-gtk 3 1))
(when border-gtk (when border-gtk
(adjust-client-delta 2 2)) (adjust-client-delta 2 2))
(connect-key-and-mouse gtk) (connect-key-and-mouse gtk)
(gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK (gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK
GDK_BUTTON_RELEASE_MASK GDK_BUTTON_RELEASE_MASK

18
gui-lib/mred/private/wx/gtk/procs.rkt
View File

@ -116,17 +116,8 @@
(g_free f)))))) (g_free f))))))
default)) default))
(define (get-control-font-size) (define (get-control-font-size)
(define s (get-control-font (lambda (m) (string->number (cadr m))) (get-control-font (lambda (m) (string->number (cadr m)))
10)) 10))
(cond
[(and gtk3?
((gtk_get_minor_version) . >= . 22))
;; As of version 3.22, a size in points ends up rounded
;; to an integral absolute size for 96 DPI; see also
;; `install-control-font`
(* (round (* s (/ 96.0 72.0))) (/ 72.0 96.0))]
[else s]))
(define (get-control-font-face) (define (get-control-font-face)
(get-control-font (lambda (m) (car m)) (get-control-font (lambda (m) (car m))
"Sans")) "Sans"))
@ -156,10 +147,9 @@
(define/top (make-screen-bitmap [exact-positive-integer? w] (define/top (make-screen-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]) [exact-positive-integer? h])
(if (and (eq? 'unix (system-type)) (if (eq? 'unix (system-type))
(not wayland?))
(make-object x11-bitmap% w h #f) (make-object x11-bitmap% w h #f)
(make-object bitmap% w h #f #t (display-bitmap-resolution 0 (lambda () 1.0))))) (make-object bitmap% w h #f #t)))
(define/top (make-gl-bitmap [exact-positive-integer? w] (define/top (make-gl-bitmap [exact-positive-integer? w]
[exact-positive-integer? h] [exact-positive-integer? h]

14
gui-lib/mred/private/wx/gtk/queue.rkt
View File

@ -16,7 +16,6 @@
try-to-sync-refresh try-to-sync-refresh
set-widget-hook! set-widget-hook!
x11-display) x11-display)
wayland?
;; from common/queue: ;; from common/queue:
current-eventspace current-eventspace
queue-event queue-event
@ -91,19 +90,6 @@
(gdk_set_program_class (cast v _pointer _string)))) (gdk_set_program_class (cast v _pointer _string))))
display)))) display))))
;; ----------------------------------------
;; Check for Wayland vs. X11
(define-gdk gdk_display_get_default (_fun -> _GdkDisplay))
(define-gdk gdk_display_get_name (_fun _GdkDisplay -> _string))
(define wayland?
(and gtk3?
(regexp-match? #rx"^wayland"
(gdk_display_get_name
(gdk_display_get_default)))))
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
;; Gtk event pump ;; Gtk event pump

5
gui-lib/mred/private/wx/gtk/utils.rkt
View File

@ -51,8 +51,6 @@
gdk_screen_get_default gdk_screen_get_default
gtk_get_minor_version
;; for declaring derived structures: ;; for declaring derived structures:
_GtkObject _GtkObject
@ -202,9 +200,6 @@
(define-gdk gdk_screen_get_default (_fun -> _GdkScreen)) (define-gdk gdk_screen_get_default (_fun -> _GdkScreen))
(define-gtk gtk_get_minor_version (_fun -> _uint)
#:fail (lambda () (lambda () 0)))
(define (mnemonic-string orig-s) (define (mnemonic-string orig-s)
(string-join (string-join
(for/list ([s (in-list (regexp-split #rx"&&" orig-s))]) (for/list ([s (in-list (regexp-split #rx"&&" orig-s))])

39
gui-lib/mred/private/wx/gtk/window.rkt
View File

@ -55,8 +55,6 @@
widget-allocation widget-allocation
widget-parent widget-parent
avoid-preferred-size-warning
the-accelerator-group the-accelerator-group
gtk_window_add_accel_group gtk_window_add_accel_group
gtk_menu_set_accel_group gtk_menu_set_accel_group
@ -104,14 +102,6 @@
(define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int) (define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int)
#:fail (lambda () (lambda (gtk) 1))) #:fail (lambda () (lambda (gtk) 1)))
(define (avoid-preferred-size-warning gtk)
;; If we don't ask for a widget's size in the right way,
;; GTK3 may report a warning; this query avoids the
;; warning.
(when gtk3?
(define req (make-GtkRequisition 0 0))
(gtk_widget_get_preferred_size gtk req #f)))
(define-gdk gdk_keyboard_grab (_fun _GdkWindow _gboolean _int -> _void)) (define-gdk gdk_keyboard_grab (_fun _GdkWindow _gboolean _int -> _void))
(define-gdk gdk_keyboard_ungrab (_fun _int -> _void)) (define-gdk gdk_keyboard_ungrab (_fun _int -> _void))
@ -259,9 +249,6 @@
(lambda (gtk event) (lambda (gtk event)
(do-key-event gtk event #f #t))) (do-key-event gtk event #f #t)))
(define scroll-accum-x 0)
(define scroll-accum-y 0)
(define (do-key-event gtk event down? scroll?) (define (do-key-event gtk event down? scroll?)
(let ([wx (gtk->wx gtk)]) (let ([wx (gtk->wx gtk)])
(and (and
@ -292,22 +279,12 @@
[(= dir GDK_SCROLL_RIGHT) 'wheel-right] [(= dir GDK_SCROLL_RIGHT) 'wheel-right]
[(= dir GDK_SCROLL_SMOOTH) [(= dir GDK_SCROLL_SMOOTH)
(define-values (dx dy) (gdk_event_get_scroll_deltas event)) (define-values (dx dy) (gdk_event_get_scroll_deltas event))
(set! scroll-accum-x (+ scroll-accum-x dx))
(set! scroll-accum-y (+ scroll-accum-y dy))
(cond (cond
[(>= scroll-accum-y 1) [(positive? dy) 'wheel-down]
(set! scroll-accum-y (sub1 scroll-accum-y)) [(negative? dy) 'wheel-up]
'wheel-down] [(positive? dx) 'wheel-right]
[(<= scroll-accum-y -1) [(negative? dx) 'wheel-left]
(set! scroll-accum-y (add1 scroll-accum-y)) [else #f])]
'wheel-up]
[(>= scroll-accum-x 1)
(set! scroll-accum-x (sub1 scroll-accum-x))
'wheel-right]
[(<= scroll-accum-x -1)
(set! scroll-accum-x (add1 scroll-accum-x))
'wheel-left]
[else #f])]
[else #f]))] [else #f]))]
[(and (string? im-str) [(and (string? im-str)
(= 1 (string-length im-str))) (= 1 (string-length im-str)))
@ -637,7 +614,7 @@
(set! client-delta-h (->normal (set! client-delta-h (->normal
(- (GtkRequisition-height req) (- (GtkRequisition-height req)
(GtkRequisition-height creq))))) (GtkRequisition-height creq)))))
(when gtk3? (gtk_widget_hide gtk)))) (when gtk3? (gtk_widget_show gtk))))
(define/public (set-auto-size [dw 0] [dh 0]) (define/public (set-auto-size [dw 0] [dh 0])
(let ([req (make-GtkRequisition 0 0)]) (let ([req (make-GtkRequisition 0 0)])
@ -656,7 +633,7 @@
(define/public (direct-show on?) (define/public (direct-show on?)
;; atomic mode ;; atomic mode
(if on? (if on?
(gtk_widget_show gtk) (gtk_widget_show gtk)
(gtk_widget_hide gtk)) (gtk_widget_hide gtk))
(set! shown? (and on? #t)) (set! shown? (and on? #t))
(register-child-in-parent on?) (register-child-in-parent on?)
@ -926,7 +903,7 @@
;; windows; that means we have to be extra careful that ;; windows; that means we have to be extra careful that
;; the underlying window doesn't change while a freeze is ;; the underlying window doesn't change while a freeze is
;; in effect; the `reset-child-freezes` helps with that. ;; in effect; the `reset-child-freezes` helps with that.
(unless (or (and transparentish? gtk3?) wayland?) (unless (and transparentish? gtk3?)
(gdk_window_ensure_native win)) (gdk_window_ensure_native win))
(begin (begin
(gdk_window_freeze_updates win) (gdk_window_freeze_updates win)

2
gui-lib/mred/private/wxtop.rkt
View File

@ -407,7 +407,7 @@
[center (lambda (dir) [center (lambda (dir)
(when pending-redraws? (force-redraw)) (when pending-redraws? (force-redraw))
(set! use-default-position? #f) (set! use-default-position? #f)
(super center dir parent-for-center))] ; 2nd argument is for Mac OS (super center dir parent-for-center))] ; 2nd argument is for Mac OS X
;; on-size: ensures that size of frame matches size of content ;; on-size: ensures that size of frame matches size of content
;; input: new-width/new-height: new size of frame ;; input: new-width/new-height: new size of frame

165
gui-lib/mrlib/syntax-browser.rkt
View File

@ -1,6 +1,4 @@
#lang racket/base #lang racket/base
(module+ test (require rackunit))
#| #|
needed to really make this work: needed to really make this work:
@ -13,20 +11,13 @@ needed to really make this work:
racket/class racket/class
racket/gui/base racket/gui/base
racket/match racket/match
racket/contract (prefix-in - racket/base)
(prefix-in : racket/base)
"include-bitmap.rkt") "include-bitmap.rkt")
(define orig-output-port (current-output-port)) (define orig-output-port (current-output-port))
(define (oprintf . args) (apply fprintf orig-output-port args)) (define (oprintf . args) (apply fprintf orig-output-port args))
(provide (provide render-syntax/snip render-syntax/window snip-class)
(contract-out
[render-syntax/snip
(-> syntax? (is-a?/c snip%))]
[render-syntax/window
(-> syntax? void?)])
snip-class)
;; this is doing the same thing as the class in ;; this is doing the same thing as the class in
;; the framework by the same name, but we don't ;; the framework by the same name, but we don't
@ -56,7 +47,7 @@ needed to really make this work:
(class snip-class% (class snip-class%
(define/override (read stream) (define/override (read stream)
(make-object syntax-snip% (make-object syntax-snip%
(unmarshall-syntax (:read (open-input-bytes (send stream get-bytes)))))) (unmarshall-syntax (-read (open-input-bytes (send stream get-bytes))))))
(super-new))) (super-new)))
(define snip-class (new syntax-snipclass%)) (define snip-class (new syntax-snipclass%))
@ -79,6 +70,8 @@ needed to really make this work:
(define/override (write stream) (define/override (write stream)
(send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx))))) (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx)))))
(define path '())
(define next-push 0)
(define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx)) (define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx))
(define output-text (new text:hide-caret/selection%)) (define output-text (new text:hide-caret/selection%))
@ -91,16 +84,69 @@ needed to really make this work:
(make-object style-delta% 'change-family 'modern) (make-object style-delta% 'change-family 'modern)
0 0
(send text last-position))) (send text last-position)))
(define path '())
(define next-push 0)
(define/private (push!) (define/private (push!)
(set! path (cons next-push path)) (set! path (cons next-push path))
(set! next-push 0)) (set! next-push 0))
(define/private (pop!) (define/private (pop!)
(set! next-push (+ (car path) 1)) (set! next-push (+ (car path) 1))
(set! path (cdr path))) (set! path (cdr path)))
;; record-paths : val -> hash-table[path -o> syntax-object]
(define/private (syntax-object->datum/record-paths val)
(set! path '())
(set! next-push 0)
(let* ([ht (make-hash)]
[record
(λ (val enclosing-stx)
(hash-set! ht path enclosing-stx))])
(values
(let loop ([val val]
[enclosing-stx #f])
(cond
[(syntax? val)
(loop (syntax-e val)
val)]
[(pair? val)
(push!)
(record val enclosing-stx)
(begin0
(let lst-loop ([val val])
(cond
[(pair? val)
(cons (loop (car val) #f)
(lst-loop (cdr val)))]
[(null? val) '()]
[else
(loop val enclosing-stx)]))
(pop!))]
[(vector? val)
(push!)
(record val enclosing-stx)
(begin0
(apply
vector
(let lst-loop ([val (vector->list val)])
(cond
[(pair? val)
(cons (loop (car val) #f)
(lst-loop (cdr val)))]
[(null? val) '()])))
(pop!))]
[(hash? val)
(push!)
(record val enclosing-stx)
(begin0
(for/hash ([(k v) (in-hash val)])
(values (loop k #f)
(loop v #f)))
(pop!))]
[else
(push!)
(record val enclosing-stx)
(pop!)
val]))
ht)))
(define/private (populate-range-ht) (define/private (populate-range-ht)
;; range-start-ht : hash-table[obj -o> number] ;; range-start-ht : hash-table[obj -o> number]
(define range-start-ht (make-hasheq)) (define range-start-ht (make-hasheq))
@ -397,92 +443,7 @@ needed to really make this work:
(inherit set-snipclass) (inherit set-snipclass)
(set-snipclass snip-class))) (set-snipclass snip-class)))
;; record-paths : val -> hash-table[path -o> syntax-object]
(define (syntax-object->datum/record-paths val)
(define path '())
(define next-push 0)
(define (push!)
(set! path (cons next-push path))
(set! next-push 0))
(define (pop!)
(set! next-push (+ (car path) 1))
(set! path (cdr path)))
(let* ([ht (make-hash)]
[record
(λ (val enclosing-stx)
(hash-set! ht path enclosing-stx))])
(values
(let loop ([val val]
[enclosing-stx #f])
(cond
[(syntax? val)
(loop (syntax-e val)
val)]
[(pair? val)
(push!)
(record val enclosing-stx)
(begin0
(let lst-loop ([val val])
(cond
[(pair? val)
(cons (loop (car val) #f)
(lst-loop (cdr val)))]
[(null? val) '()]
[(and (syntax? val) (pair? (syntax-e val)))
(define pr (syntax-e val))
(lst-loop pr)]
[else
(loop val enclosing-stx)]))
(pop!))]
[(vector? val)
(push!)
(record val enclosing-stx)
(begin0
(apply
vector
(let lst-loop ([val (vector->list val)])
(cond
[(pair? val)
(cons (loop (car val) #f)
(lst-loop (cdr val)))]
[(null? val) '()])))
(pop!))]
[(hash? val)
(push!)
(record val enclosing-stx)
(begin0
(for/hash ([(k v) (in-hash val)])
(values (loop k #f)
(loop v #f)))
(pop!))]
[else
(push!)
(record val enclosing-stx)
(pop!)
val]))
ht)))
(module+ test
(let ([x (datum->syntax #f 'x #f #f)]
[y (datum->syntax #f 'y #f #f)])
(check-equal? (call-with-values
(λ ()
(syntax-object->datum/record-paths (list x y)))
list)
(list '(x y)
(make-hash `(((0) . #f) ((1 0) . ,y) ((0 0) . ,x))))))
(let* ([x (datum->syntax #f 'x #f #f)]
[y (datum->syntax #f 'y #f #f)]
[ly (datum->syntax #f (list y) #f #f)])
(check-equal? (call-with-values
(λ ()
(syntax-object->datum/record-paths (cons x ly)))
list)
(list '(x y)
(make-hash `(((0) . #f) ((1 0) . ,y) ((0 0) . ,x)))))))
(define black-style-delta (make-object style-delta% 'change-normal-color)) (define black-style-delta (make-object style-delta% 'change-normal-color))
(define green-style-delta (make-object style-delta%)) (define green-style-delta (make-object style-delta%))
(void (send green-style-delta set-delta-foreground "forest green")) (void (send green-style-delta set-delta-foreground "forest green"))

5
gui-lib/racket/gui/installer.rkt
View File

@ -27,10 +27,7 @@
#:tether-mode tether-mode #:tether-mode tether-mode
'("-z") '("-z")
(prep-dir (prep-dir
(mred-program-launcher-path "gracket-text" (mred-program-launcher-path "gracket-text" #:user? user? #:tethered? tethered?))
#:user? user?
#:tethered? tethered?
#:console? #t))
`([subsystem . console] `([subsystem . console]
[single-instance? . #f] [single-instance? . #f]
[relative? . ,(not (or user? tethered?))])))))) [relative? . ,(not (or user? tethered?))]))))))

28
gui-lib/racket/gui/private/distro-test.rkt
View File

@ -1,28 +0,0 @@
#lang racket/base
(require setup/dirs
racket/system)
;; Sanity checks to run in an installer-building context to make sure
;; that things bascially work. This test is in the "-lib" package,
;; instead of the "-test" package, so that it's lightweight to run
;; (without installing lots of other packages)
(define bin-dir (find-gui-bin-dir))
(define console-bin-dir (find-console-bin-dir))
(define (try-exe p)
(printf "Trying ~a\n" p)
(let ([o (open-output-bytes)])
(parameterize ([current-output-port o])
(system* p "-e" "'hello"))
;; For historical reasons, `gracket` still uses `scheme` printing
(unless (equal? #"hello\n" (get-output-bytes o))
(error "sanity check failed" p))))
(try-exe (build-path console-bin-dir (if (eq? (system-type) 'windows)
"gracket-text.exe"
"gracket-text")))
(unless (eq? (system-type) 'unix) ; may not have a GUI connection on Unix
(case (system-type)
[(windows) (try-exe (build-path bin-dir "GRacket.exe"))]
[(macosx) (try-exe (build-path console-bin-dir "gracket"))]))

1086
gui-lib/scribble/private/indentation.rkt
View File

File diff suppressed because it is too large Load Diff

10
gui-test/framework/tests/README
View File

@ -36,7 +36,7 @@ signal failures when there aren't any.
| This tests that exit:exit really exits and that the exit callbacks | This tests that exit:exit really exits and that the exit callbacks
| are actually run. | are actually run.
- preferences: prefs.rkt -- now runs directly via raco test - preferences: |# prefs.rkt #|
| This tests that preferences are saved and restored correctly, both | This tests that preferences are saved and restored correctly, both
| immediately and across reboots of gracket. | immediately and across reboots of gracket.
@ -50,10 +50,10 @@ signal failures when there aren't any.
- frames: frame.rkt -- now runs directly via raco test. - frames: frame.rkt -- now runs directly via raco test.
- canvases: canvas.rkt -- now runs directly via raco test. - canvases: canvas.rkt -- now runs directly via raco test.
- texts: text.rkt -- now runs directly via raco test. - texts: |# text.rkt #|
- pasteboards: |# pasteboard.rkt #| - pasteboards: |# pasteboard.rkt #|
- keybindings: keys.rkt -- now runs directly via raco test. - keybindings: |# keys.rkt #|
| This tests the misc (non-scheme) keybindings | This tests the misc (non-scheme) keybindings
@ -61,12 +61,12 @@ signal failures when there aren't any.
| This tests the search results | This tests the search results
- group tests: group-test.rkt -- now runs directly via raco test - group tests: |# group-test.rkt #|
| make sure that mred:the-frame-group records frames correctly. | make sure that mred:the-frame-group records frames correctly.
| fake user input expected. | fake user input expected.
- number snip: number-snip.rkt -- now runs directly via raco test - number snip: |# number-snip.rkt #|
| some tests for the number-snip% class | some tests for the number-snip% class

2
gui-test/framework/tests/canvas.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require "private/util.rkt" (require "private/here-util.rkt"
framework framework
racket/class racket/class
racket/gui/base racket/gui/base

207
gui-test/framework/tests/frame.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require "private/util.rkt" (require "private/here-util.rkt"
"private/gui.rkt" "private/gui.rkt"
rackunit rackunit
racket/class racket/class
racket/gui/base racket/gui/base
framework) framework)
(define (test-creation name create [verify void]) (define (test-creation name create)
(check-true (check-true
(let () (let ()
(parameterize ([current-eventspace (make-eventspace)]) (parameterize ([current-eventspace (make-eventspace)])
@ -20,7 +20,6 @@
(channel-put c (send f get-label)))) (channel-put c (send f get-label))))
(define frame-label (channel-get c)) (define frame-label (channel-get c))
(wait-for-frame frame-label) (wait-for-frame frame-label)
(verify f)
(queue-callback (λ () (send f close))) (queue-callback (λ () (send f close)))
#t)) #t))
(format "create ~a" name))) (format "create ~a" name)))
@ -87,72 +86,6 @@
'pasteboard%-creation 'pasteboard%-creation
(λ () (new frame:pasteboard%)))) (λ () (new frame:pasteboard%))))
(define (frame/text-creation-tests)
(define (mk-create f% e%)
(λ ()
(define f
(new (class f%
(define/override (get-editor%) e%)
(super-new))))
(send (send f get-editor) set-max-undo-history 10)
f))
(define (verify f)
(test:keystroke #\a)
(wait-for/here
(λ ()
(define f (test:get-active-top-level-window))
(and f
(string=? "a" (send (send f get-editor) get-text)))))
(queue-callback
(λ ()
(define f (test:get-active-top-level-window))
;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
(send (send f get-editor) undo)
(send (send f get-editor) undo)
(send (send f get-editor) lock #t)
(send (send f get-editor) lock #f))))
(test-creation 'text:basic-mixin-creation
(mk-create frame:text% (text:basic-mixin (editor:basic-mixin text%)))
verify)
(test-creation 'text:basic-creation
(mk-create frame:text% text:basic%))
(test-creation 'editor:file-mixin-creation
(mk-create frame:text% (editor:file-mixin text:keymap%))
verify)
(test-creation 'text:file-creation
(mk-create frame:text% text:file%)
verify)
(test-creation 'text:clever-file-format-mixin-creation
(mk-create frame:text% (text:clever-file-format-mixin text:file%))
verify)
(test-creation 'text:clever-file-format-creation
(mk-create frame:text% text:clever-file-format%)
verify)
(test-creation 'editor:backup-autosave-mixin-creation
(mk-create frame:text% (editor:backup-autosave-mixin text:clever-file-format%))
verify)
(test-creation 'text:backup-autosave-creation
(mk-create frame:text% text:backup-autosave%)
verify)
(test-creation 'text:searching-mixin-creation
(mk-create frame:text% (text:searching-mixin text:backup-autosave%))
verify)
(test-creation 'text:searching-creation
(mk-create frame:text% text:searching%)
verify)
(test-creation 'text:info-mixin-creation
(mk-create (frame:searchable-mixin frame:text%)
(text:info-mixin (editor:info-mixin text:searching%)))
verify)
(test-creation 'text:info-creation
(mk-create (frame:searchable-mixin frame:text%)
text:info%)
verify))
(define (test-open name cls) (define (test-open name cls)
(define test-file-contents "test") (define test-file-contents "test")
(check-equal? (check-equal?
@ -203,125 +136,19 @@
(test-open "frame:searchable open" frame:searchable%) (test-open "frame:searchable open" frame:searchable%)
(test-open "frame:text open" frame:text%)) (test-open "frame:text open" frame:text%))
(define (replace-all-tests) (let ([pref-ht (make-hash)])
(parameterize ([current-eventspace (make-eventspace)]) (parameterize ([test:use-focus-table #t]
(define plain-f [preferences:low-level-get-preference
(let () (λ (sym [fail (λ () #f)])
(define c (make-channel)) (hash-ref pref-ht sym fail))]
(queue-callback [preferences:low-level-put-preferences
(λ () (λ (syms vals)
(define f (new frame:searchable% [width 400] [height 400])) (for ([sym (in-list syms)]
(send f show #t) [val (in-list vals)])
(channel-put c f))) (hash-set! pref-ht sym val)))])
(channel-get c))) (define dummy (make-object frame:basic% "dummy to keep from quitting"))
(send dummy show #t)
(define (try f content search-string replace-string) (creation-tests)
(define c (make-channel)) (open-tests)
(queue-callback (send dummy show #f)))
(λ ()
(define t (send f get-editor))
(send f set-text-to-search t)
(send t erase)
(send f unhide-search #t)))
;; wait for search to get the focus
(let ([s (make-semaphore)])
(queue-callback (λ () (semaphore-post s)) #f)
(semaphore-wait s))
(for ([c (in-string search-string)])
(test:keystroke c))
(queue-callback
(λ ()
;; show it.
(send f edit-menu:show/hide-replace-callback 'ignored.1 'ignored.2)))
;; wait for replace to get the focus
(let ([s (make-semaphore)])
(queue-callback (λ () (semaphore-post s)) #f)
(semaphore-wait s))
(test:menu-select "Edit" "Select All")
(cond
[(equal? replace-string "")
(test:keystroke #\backspace)]
[else
(for ([c (in-string replace-string)])
(test:keystroke c))])
(queue-callback
(λ ()
(define t (send f get-editor))
(send t insert content)
(send f replace-all)
;; hide it again
(send f edit-menu:show/hide-replace-callback 'ignored.1 'ignored.2)
(send f hide-search)
(channel-put c (send t get-text))))
(channel-get c))
(check-equal? (try plain-f "a" "a" "b") "b")
(check-equal? (try plain-f "aa" "a" "b") "bb")
(check-equal? (try plain-f "abab" "ab" "c") "cc")
(check-equal? (try plain-f "abb" "ab" "a") "ab")
(check-equal? (try plain-f "babbbcb" "b" "") "ac")
(send plain-f close)
(define (make-no-change-early-f)
(define c (make-channel))
(queue-callback
(λ ()
(define f (new (class (frame:searchable-mixin
(frame:text-mixin
(frame:editor-mixin
(frame:standard-menus-mixin
frame:basic%))))
(super-new [editor%
(class text:searching%
(define allow-delete? #f)
(define/public (allow-delete) (set! allow-delete? #t))
(define/augment (can-delete? start len)
(if allow-delete?
#t
(> start 0)))
(super-new)
(inherit set-max-undo-history)
(set-max-undo-history 'forever))]
[width 400]
[height 400]))))
(send f show #t)
(channel-put c f)))
(channel-get c))
(define (close-up-no-change-early-f no-change-early-f)
(queue-callback
(λ ()
(define t (send no-change-early-f get-editor))
(send t allow-delete)
(let loop ()
(unless (= 0 (send t last-position))
(send t undo)
(loop)))
(send no-change-early-f close))))
(let ()
(define no-change-early-f (make-no-change-early-f))
(check-equal? (try no-change-early-f "aaaa" "a" "b") "abbb")
(close-up-no-change-early-f no-change-early-f))
(let ()
(define no-change-early-f (make-no-change-early-f))
(check-equal? (try no-change-early-f "aaaa" "a" "bbbbbbbbbb") "abbbbbbbbbbbbbbbbbbbbbbbbbbbbbb")
(close-up-no-change-early-f no-change-early-f))))
(with-private-prefs
(parameterize ([test:use-focus-table #t])
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
(send dummy show #t)
(creation-tests)
(open-tests)
(replace-all-tests)
(frame/text-creation-tests)
(send dummy show #f)))

328
gui-test/framework/tests/group-test.rkt
View File

@ -1,12 +1,7 @@
#lang racket/base #lang racket/base
(require "private/util.rkt" (require "test-suite-utils.rkt")
"private/gui.rkt"
rackunit (module test racket/base)
racket/class
racket/gui/base
framework
(only-in "../../../gui-lib/framework/private/group.rkt"
pay-attention-to-current-eventspace-has-standard-menus?))
(define windows-menu-prefix (define windows-menu-prefix
(let ([basics (list "Bring Frame to Front…" "Most Recent Window" (let ([basics (list "Bring Frame to Front…" "Most Recent Window"
@ -14,155 +9,180 @@
(if (eq? (system-type) 'macosx) (if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" basics) (list* "Minimize" "Zoom" basics)
basics))) basics)))
(send-sexp-to-mred
'(define-syntax car*
(syntax-rules ()
[(car* x) (if (pair? x)
(car x)
(error 'car* "got a non-pair for ~s" 'x))])))
(with-private-prefs ;; this test uses a new eventspace so that the gracket function
(parameterize ([test:use-focus-table #t] ;; current-eventspace-has-standard-menus? returns #f and thus
[pay-attention-to-current-eventspace-has-standard-menus? #f]) ;; all of the platforms behave the same way.
(test
'exit-on
(lambda (x) (equal? x '("first")))
(lambda ()
(send-sexp-to-mred `(define new-eventspace (make-eventspace)))
(send-sexp-to-mred
'(begin (parameterize ([current-eventspace new-eventspace])
(send (make-object frame:basic% "first") show #t))
(preferences:set 'framework:verify-exit #t)))
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(queue-callback (lambda ()
(parameterize ([current-eventspace new-eventspace])
(send (get-top-level-focus-window) close)))))
(wait-for-frame "Warning" 'new-eventspace)
(send-sexp-to-mred
`(parameterize ([current-eventspace new-eventspace])
(test:button-push "Cancel")))
(wait-for-frame "first" 'new-eventspace)
(send-sexp-to-mred
`(parameterize ([current-eventspace new-eventspace])
(map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames))))))
(define-syntax car* ;; after the first test, we should have one frame that will always
(syntax-rules () ;; be in the group.
[(car* x-expr)
(let ([x x-expr])
(if (pair? x)
(car x)
(begin
(eprintf "car* called with ~s\n" 'x-expr)
(car x))))]))
(define the-first-frame #f) (test
'one-frame-registered
(lambda (x) (equal? x (list "test" "first")))
(lambda ()
(queue-sexp-to-mred
`(send (make-object frame:basic% "test") show #t))
(wait-for-frame "test")
(queue-sexp-to-mred
`(begin0 (map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames))
(send (get-top-level-focus-window) close)))))
(yield (test
(thread 'two-frames-registered
(λ () (lambda (x) (equal? x (list "test2" "test1" "first")))
(queue-callback (lambda ()
(λ () (queue-sexp-to-mred
(set! the-first-frame (make-object frame:basic% "first")) '(send (make-object frame:basic% "test1") show #t))
(send the-first-frame show #t))) (wait-for-frame "test1")
(preferences:set 'framework:verify-exit #t) (queue-sexp-to-mred
(wait-for-frame "first") '(send (make-object frame:basic% "test2") show #t))
(queue-callback (wait-for-frame "test2")
(λ () (queue-sexp-to-mred
(send (test:get-active-top-level-window) close))) `(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
(wait-for-frame "Warning") (for-each (lambda (x)
(test:button-push "Cancel") (unless (equal? (send x get-label) "first")
(wait-for-frame "first")))) (send x close)))
(check-equal? (map (lambda (x) (send x get-label)) frames)
(send (group:get-the-frame-group) get-frames)) (map (lambda (x) (send x get-label)) frames))))))
'("first"))
;; after the first test, we should have one frame (test
;; that will always be in the group. 'one-frame-unregistered
(lambda (x) (equal? x (list "test1" "first")))
(lambda ()
(queue-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1")
(queue-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2")
(queue-sexp-to-mred
`(send (get-top-level-focus-window) close))
(queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames)
(map (lambda (x) (send x get-label)) frames)))))
(check-equal? (when (eq? (system-type) 'macosx)
(let ()
(send (make-object frame:basic% "test") show #t) (test
(define ans (map (lambda (x) (send x get-label)) 'windows-menu
(send (group:get-the-frame-group) get-frames))) (lambda (x)
(send (test:get-active-top-level-window) close) (equal? x (append windows-menu-prefix (list "first" "test"))))
ans) (λ ()
(list "test" "first")) (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "test")])
(send frame show #t)))
(begin (wait-for-frame "test")
(yield (queue-sexp-to-mred
(thread '(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
(λ () (send mb on-demand)
(queue-callback (define labels
(λ () (send (make-object frame:basic% "test1") show #t))) (for/list ([x (send (car* (send mb get-items)) get-items)])
(wait-for-frame "test1") (and (is-a? x labelled-menu-item<%>) (send x get-label))))
(queue-callback (send (get-top-level-focus-window) close)
(λ () (send (make-object frame:basic% "test2") show #t))) labels))))
(wait-for-frame "test2"))))
(check-equal? (test
(let ([frames (send (group:get-the-frame-group) get-frames)]) 'windows-menu-unshown
(for-each (lambda (x) (lambda (x)
(unless (equal? (send x get-label) "first") (equal? x (append windows-menu-prefix (list "first" "test"))))
(send x close))) (lambda ()
frames) (queue-sexp-to-mred
(map (lambda (x) (send x get-label)) frames)) '(let ([frame1 (make-object frame:basic% "test")]
(list "test2" "test1" "first"))) [frame2 (make-object frame:basic% "test-not-shown")])
(send frame1 show #t)))
(begin (wait-for-frame "test")
(yield (queue-sexp-to-mred
(thread '(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
(λ () (send mb on-demand)
(queue-callback (define items
(λ () (for/list ([x (send (car* (send mb get-items)) get-items)])
(send (make-object frame:basic% "test1") show #t))) (and (is-a? x labelled-menu-item<%>) (send x get-label))))
(wait-for-frame "test1") (send (get-top-level-focus-window) close)
(queue-callback items))))
(λ ()
(send (make-object frame:basic% "test2") show #t))) (test
(wait-for-frame "test2")))) 'windows-menu-sorted1
(send (test:get-active-top-level-window) close) (lambda (x)
(check-equal? (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(let ([frames (send (group:get-the-frame-group) get-frames)]) (lambda ()
(for-each (lambda (x) (queue-sexp-to-mred
(unless (equal? (send x get-label) "first") '(let ([frame (make-object frame:basic% "aaa")])
(send x close))) (send frame show #t)))
frames) (wait-for-frame "aaa")
(map (lambda (x) (send x get-label)) frames)) (queue-sexp-to-mred
(list "test1" "first"))) '(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t)))
(wait-for-frame "bbb")
(when (eq? (system-type) 'macosx) (queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(check-equal? (define mb (send (car* frames) get-menu-bar))
(begin (send mb on-demand)
(send (make-object frame:basic% "test") show #t) (begin0 (map (lambda (x)
(let ([mb (send (test:get-active-top-level-window) get-menu-bar)]) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send mb on-demand) (send (car* (send mb get-items))
(define labels get-items))
(for/list ([x (send (car* (send mb get-items)) get-items)]) (for-each (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label)))) (unless (equal? (send x get-label) "first")
(send (test:get-active-top-level-window) close) (send x close)))
labels)) frames))))))
(append windows-menu-prefix (list "first" "test")))
(test
(check-equal? 'windows-menu-sorted2
(let () (lambda (x)
(define frame1 (make-object frame:basic% "test")) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(define frame2 (make-object frame:basic% "test-not-shown")) (lambda ()
(send frame1 show #t) (queue-sexp-to-mred
(define mb (send (test:get-active-top-level-window) get-menu-bar)) '(let ([frame (make-object frame:basic% "bbb")])
(send mb on-demand) (send frame show #t)))
(define items (wait-for-frame "bbb")
(for/list ([x (send (car* (send mb get-items)) get-items)]) (queue-sexp-to-mred
(and (is-a? x labelled-menu-item<%>) (send x get-label)))) '(let ([frame (make-object frame:basic% "aaa")])
(send (test:get-active-top-level-window) close) (send frame show #t)))
items) (wait-for-frame "aaa")
(append windows-menu-prefix (list "first" "test"))) (queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)])
(define (get-label-and-close-non-first) (define mb (send (car* frames) get-menu-bar))
(define frames (send (group:get-the-frame-group) get-frames)) (send mb on-demand)
(define mb (send (car* frames) get-menu-bar)) (begin0 (map (lambda (x)
(send mb on-demand) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(define ans (send (car* (send mb get-items))
(for/list ([x (in-list (send (car* (send mb get-items)) get-items))
get-items))]) (for-each (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label)))) (unless (equal? (send x get-label) "first")
(for ([x (in-list frames)]) (send x close)))
(unless (equal? (send x get-label) "first") frames)))))))
(send x close)))
ans)
(check-equal?
(let ()
(define aaa-frame (make-object frame:basic% "aaa"))
(send aaa-frame show #t)
(define bbb-frame (make-object frame:basic% "bbb"))
(send bbb-frame show #t)
(get-label-and-close-non-first))
(append windows-menu-prefix (list "aaa" "bbb" "first")))
(check-equal?
(let ()
(define bbb-frame (make-object frame:basic% "bbb"))
(send bbb-frame show #t)
(define aaa-frame (make-object frame:basic% "aaa"))
(send aaa-frame show #t)
(get-label-and-close-non-first))
(append windows-menu-prefix (list "aaa" "bbb" "first"))))
;; close that original frame so the test suite can exit if run from `racket`
(send the-first-frame show #f)))

910
gui-test/framework/tests/keys.rkt
View File

@ -1,195 +1,236 @@
#lang racket/gui #lang racket/base
(require framework rackunit "private/util.rkt")
(check-equal? (require "test-suite-utils.rkt")
(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "abc" void)
(send k map-function "c:k" "abc")
(hash-map (send k get-map-function-table) list))
'((c:k "abc")))
(check-equal? (module test racket/base)
(let ([k (make-object keymap:aug-keymap%)]
[ht (make-hasheq)]) (test
(send k add-function "abc" void) 'keymap:aug-keymap%/get-table
(send k map-function "c:k" "abc") (lambda (x)
(hash-set! ht 'c:k "def") (equal? '((c:k "abc")) x))
(hash-map (send k get-map-function-table/ht ht) list)) (lambda ()
'((c:k "def"))) (queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "abc" void)
(send k map-function "c:k" "abc")
(hash-map (send k get-map-function-table) list)))))
(test
'keymap:aug-keymap%/get-table/ht
(lambda (x)
(equal? x '((c:k "def"))))
(lambda ()
(queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)]
[ht (make-hasheq)])
(send k add-function "abc" void)
(send k map-function "c:k" "abc")
(hash-set! ht 'c:k "def")
(hash-map (send k get-map-function-table/ht ht) list)))))
(test
'keymap:aug-keymap%/get-table/chain1
(lambda (x)
(equal? x '((c:k "abc-k2"))))
(lambda ()
(queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)]
[k1 (make-object keymap:aug-keymap%)]
[k2 (make-object keymap:aug-keymap%)])
(send k1 add-function "abc-k1" void)
(send k1 map-function "c:k" "abc-k1")
(send k2 add-function "abc-k2" void)
(send k2 map-function "c:k" "abc-k2")
(send k chain-to-keymap k1 #t)
(send k chain-to-keymap k2 #t)
(hash-map (send k get-map-function-table) list)))))
(test
'keymap:aug-keymap%/get-table/chain/2
(lambda (x)
(equal? x '((c:k "abc-k"))))
(lambda ()
(queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)]
[k1 (make-object keymap:aug-keymap%)])
(send k1 add-function "abc-k1" void)
(send k1 map-function "c:k" "abc-k1")
(send k add-function "abc-k" void)
(send k map-function "c:k" "abc-k")
(send k chain-to-keymap k1 #t)
(hash-map (send k get-map-function-table) list)))))
(test
'keymap:aug-keymap%/get-table/normalize-case
(lambda (x)
(equal? x '((|esc;p| "abc-k2"))))
(lambda ()
(queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)]
[k1 (make-object keymap:aug-keymap%)])
(send k1 add-function "abc-k1" void)
(send k1 map-function "esc;p" "abc-k1")
(send k add-function "abc-k2" void)
(send k map-function "ESC;p" "abc-k2")
(send k chain-to-keymap k1 #t)
(hash-map (send k get-map-function-table) list)))))
(check-equal? (test
(let ([k (make-object keymap:aug-keymap%)] 'keymap:aug-keymap%/all-but-last-bug
[k1 (make-object keymap:aug-keymap%)] (lambda (x)
[k2 (make-object keymap:aug-keymap%)]) (equal? x '((s:a "shift-ah") (s:m "shift-em"))))
(send k1 add-function "abc-k1" void) (lambda ()
(send k1 map-function "c:k" "abc-k1") (queue-sexp-to-mred
(send k2 add-function "abc-k2" void) '(let ([k (make-object keymap:aug-keymap%)])
(send k2 map-function "c:k" "abc-k2") (send k add-function "shift-em" void)
(send k chain-to-keymap k1 #t) (send k add-function "shift-ah" void)
(send k chain-to-keymap k2 #t) (send k map-function "s:m" "shift-em")
(hash-map (send k get-map-function-table) list)) (send k map-function "s:a" "shift-ah")
'((c:k "abc-k2"))) (sort (hash-map (send k get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
(check-equal? (test
(let ([k (make-object keymap:aug-keymap%)] 'keymap:aug-keymap%/longer-name
[k1 (make-object keymap:aug-keymap%)]) (lambda (x)
(send k1 add-function "abc-k1" void) (equal? x '((|c:x;r| "swap if branches"))))
(send k1 map-function "c:k" "abc-k1") (lambda ()
(send k add-function "abc-k" void) (queue-sexp-to-mred
(send k map-function "c:k" "abc-k") '(let ()
(send k chain-to-keymap k1 #t) (define k0 (new keymap:aug-keymap%))
(hash-map (send k get-map-function-table) list)) (define k1 (new keymap:aug-keymap%))
'((c:k "abc-k"))) (define k2 (new keymap:aug-keymap%))
(send k1 add-function "rectangle" void)
(send k1 map-function "c:x;r;a" "rectangle")
(send k2 add-function "swap if branches" void)
(send k2 map-function "c:x;r" "swap if branches")
(send k0 chain-to-keymap k1 #t)
(send k0 chain-to-keymap k2 #t)
(sort (hash-map (send k0 get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
(define (test-canonicalize name str1 str2)
(test
(string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
(lambda (x)
(string=? x str2))
(lambda ()
(queue-sexp-to-mred
`(keymap:canonicalize-keybinding-string ,str1)))))
(test-canonicalize 1 "c:a" "c:a")
(test-canonicalize 2 "d:a" "d:a")
(test-canonicalize 3 "m:a" "m:a")
(test-canonicalize 4 "a:a" "a:a")
(test-canonicalize 5 "s:a" "s:a")
(test-canonicalize 6 "c:a" "c:a")
(test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
(test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
(test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
(test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
(test-canonicalize 11 "esc;s:a" "esc;s:a")
(test-canonicalize 12 "s:a;esc" "s:a;esc")
(test-canonicalize 13 "ESC;p" "esc;p")
(test-canonicalize 14 "?:a:v" "?:a:v")
(test-canonicalize 15 "a:?:v" "?:a:v")
(test-canonicalize 16 "l:v" "l:v")
(test-canonicalize 17 "c:l:v" "c:l:v")
;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?))
;; a key-spec represents a test case for a key; 'before' contains the
;; content of a buffer, and 'after' represents the desired content of the
;; buffer after the keypress. The keypress(es) in question are specified
;; independently for the three platforms by the respective 'macos', 'unix',
;; and 'windows' fields.
(define-struct key-spec (before after macos unix windows) #:prefab)
;; an abstraction to use when all platforms have the same sequence of keys
(define (make-key-spec/allplatforms before after keys)
(make-key-spec before after keys keys keys))
;; a buff-spec is (make-buff-spec string nat nat)
;; a buff-spec represents a buffer state; the content of the buffer,
;; and the start and end of the highlighted region.
;; the overwrite? field specifies if the overwrite mode is enabled during the test
;; (its value is ignored for the result checking)
(define-struct buff-spec (string start end overwrite?) #:prefab)
(define (build-buff-spec string start end #:overwrite? [overwrite? #f])
(make-buff-spec string start end overwrite?))
(check-equal? ;; the keybindings test cases applied to frame:text% editors
(let ([k (make-object keymap:aug-keymap%)] (define global-specs
[k1 (make-object keymap:aug-keymap%)]) (list
(send k1 add-function "abc-k1" void) (make-key-spec (build-buff-spec "abc" 1 1)
(send k1 map-function "esc;p" "abc-k1") (build-buff-spec "abc" 2 2)
(send k add-function "abc-k2" void) (list '((#\f control)) '((right)))
(send k map-function "ESC;p" "abc-k2") (list '((#\f control)) '((right)))
(send k chain-to-keymap k1 #t) (list '((#\f control)) '((right))))
(hash-map (send k get-map-function-table) list))
'((|esc;p| "abc-k2"))) (make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 2 2)
(build-buff-spec "\n" 0 0)
(check-equal? '(((#\x control) (#\o control))))
(let ([k (make-object keymap:aug-keymap%)]) (make-key-spec/allplatforms (build-buff-spec " \n \n \n \n" 7 7)
(send k add-function "shift-em" void) (build-buff-spec " \n" 1 1)
(send k add-function "shift-ah" void) '(((#\x control) (#\o control))))
(send k map-function "s:m" "shift-em") (make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 0 0)
(send k map-function "s:a" "shift-ah") (build-buff-spec "\n" 0 0)
(sort (hash-map (send k get-map-function-table) list) '(((#\x control) (#\o control))))
string<? (make-key-spec/allplatforms (build-buff-spec "abcdef\n\n\n\nxyzpdq\n" 8 8)
#:key (lambda (x) (format "~s" x)))) (build-buff-spec "abcdef\n\nxyzpdq\n" 7 7)
'((s:a "shift-ah") (s:m "shift-em"))) '(((#\x control) (#\o control))))
(check-equal? ;; TeX-compress tests
(let () (make-key-spec/allplatforms
(define k0 (new keymap:aug-keymap%)) (build-buff-spec "\\ome" 4 4)
(define k1 (new keymap:aug-keymap%)) (build-buff-spec "ω" 1 1)
(define k2 (new keymap:aug-keymap%)) '(((#\\ control))))
(send k1 add-function "rectangle" void) (make-key-spec/allplatforms
(send k1 map-function "c:x;r;a" "rectangle") (build-buff-spec "\\sub" 4 4)
(send k2 add-function "swap if branches" void) (build-buff-spec "\\subset" 7 7)
(send k2 map-function "c:x;r" "swap if branches") '(((#\\ control))))
(send k0 chain-to-keymap k1 #t) (make-key-spec/allplatforms
(send k0 chain-to-keymap k2 #t) (build-buff-spec "\\subset" 7 7)
(sort (hash-map (send k0 get-map-function-table) list) (build-buff-spec "⊂" 1 1)
string<? '(((#\\ control))))
#:key (lambda (x) (format "~s" x)))) (make-key-spec/allplatforms
'((|c:x;r| "swap if branches"))) (build-buff-spec "\\sub" 4 4)
(build-buff-spec "⊆" 1 1)
(check-equal? (keymap:canonicalize-keybinding-string "c:a") "c:a") '(((#\\ control) (#\e) (#\\ control))))))
(check-equal? (keymap:canonicalize-keybinding-string "d:a") "d:a")
(check-equal? (keymap:canonicalize-keybinding-string "m:a") "m:a") (define (build-open-bracket-spec str pos char)
(check-equal? (keymap:canonicalize-keybinding-string "a:a") "a:a") (make-key-spec (build-buff-spec str pos pos)
(check-equal? (keymap:canonicalize-keybinding-string "s:a") "s:a") (build-buff-spec
(check-equal? (keymap:canonicalize-keybinding-string "c:a") "c:a") (string-append (substring str 0 pos)
(check-equal? (keymap:canonicalize-keybinding-string "s:m:d:c:a:a") "a:c:d:m:s:a") (string char)
(check-equal? (keymap:canonicalize-keybinding-string "~s:~m:~d:~c:~a:a") "~a:~c:~d:~m:~s:a") (substring str pos (string-length str)))
(check-equal? (keymap:canonicalize-keybinding-string ":a") "~a:~c:~d:~m:~s:a") (+ pos 1)
(check-equal? (keymap:canonicalize-keybinding-string ":d:a") "~a:~c:d:~m:~s:a") (+ pos 1))
(check-equal? (keymap:canonicalize-keybinding-string "esc;s:a") "esc;s:a") (list (list (list #\[)))
(check-equal? (keymap:canonicalize-keybinding-string "s:a;esc") "s:a;esc") (list (list (list #\[)))
(check-equal? (keymap:canonicalize-keybinding-string "ESC;p") "esc;p") (list (list (list #\[)))))
(check-equal? (keymap:canonicalize-keybinding-string "?:a:v") "?:a:v")
(check-equal? (keymap:canonicalize-keybinding-string "a:?:v") "?:a:v") (define (ascii-art-box-spec before after)
(check-equal? (keymap:canonicalize-keybinding-string "l:v") "l:v") (make-key-spec/allplatforms (build-buff-spec before 0 0)
(check-equal? (keymap:canonicalize-keybinding-string "c:l:v") "c:l:v") (build-buff-spec after 0 0)
(list '((#\x control) (#\r) (#\a)))))
;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?))
;; a key-spec represents a test case for a key; 'before' contains the ;; the keybindings test cases applied to racket:text% editors
;; content of a buffer, and 'after' represents the desired content of the (define scheme-specs
;; buffer after the keypress. The keypress(es) in question are specified (list
;; independently for the three platforms by the respective 'macos', 'unix', (make-key-spec (build-buff-spec "(abc (def))" 4 4)
;; and 'windows' fields. (build-buff-spec "(abc (def))" 10 10)
(define-struct key-spec (before after macos unix windows) #:prefab) (list '((right alt)))
(list '((right alt)))
;; an abstraction to use when all platforms have the same sequence of keys (list '((right alt))))
(define (make-key-spec/allplatforms before after keys) (make-key-spec (build-buff-spec "'(abc (def))" 1 1)
(make-key-spec before after keys keys keys)) (build-buff-spec "'(abc (def))" 12 12)
(list '((right alt)))
;; a buff-spec is (make-buff-spec string nat nat) (list '((right alt)))
;; a buff-spec represents a buffer state; the content of the buffer, (list '((right alt))))
;; and the start and end of the highlighted region. #|
;; the overwrite? field specifies if the overwrite mode is enabled during the test
;; (its value is ignored for the result checking)
(define-struct buff-spec (string start end overwrite?) #:prefab)
(define (build-buff-spec string start end #:overwrite? [overwrite? #f])
(make-buff-spec string start end overwrite?))
;; the keybindings test cases applied to frame:text% editors
(define global-specs
(list
(make-key-spec (build-buff-spec "abc" 1 1)
(build-buff-spec "abc" 2 2)
(list '((#\f control)) '((right)))
(list '((#\f control)) '((right)))
(list '((#\f control)) '((right))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 2 2)
(build-buff-spec "\n" 0 0)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec " \n \n \n \n" 7 7)
(build-buff-spec " \n" 1 1)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 0 0)
(build-buff-spec "\n" 0 0)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "abcdef\n\n\n\nxyzpdq\n" 8 8)
(build-buff-spec "abcdef\n\nxyzpdq\n" 7 7)
'(((#\x control) (#\o control))))
;; TeX-compress tests
(make-key-spec/allplatforms
(build-buff-spec "\\ome" 4 4)
(build-buff-spec "ω" 1 1)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "\\subset" 7 7)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\subset" 7 7)
(build-buff-spec "⊂" 1 1)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "⊆" 1 1)
'(((#\\ control) (#\e) (#\\ control))))))
(define (build-open-bracket-spec str pos char)
(make-key-spec (build-buff-spec str pos pos)
(build-buff-spec
(string-append (substring str 0 pos)
(string char)
(substring str pos (string-length str)))
(+ pos 1)
(+ pos 1))
(list (list (list #\[)))
(list (list (list #\[)))
(list (list (list #\[)))))
(define (ascii-art-box-spec before after)
(make-key-spec/allplatforms (build-buff-spec before 0 0)
(build-buff-spec after 0 0)
(list '((#\x control) (#\r) (#\a)))))
;; the keybindings test cases applied to racket:text% editors
(define scheme-specs
(list
(make-key-spec (build-buff-spec "(abc (def))" 4 4)
(build-buff-spec "(abc (def))" 10 10)
(list '((right alt)))
(list '((right alt)))
(list '((right alt))))
(make-key-spec (build-buff-spec "'(abc (def))" 1 1)
(build-buff-spec "'(abc (def))" 12 12)
(list '((right alt)))
(list '((right alt)))
(list '((right alt))))
#|
(make-key-spec (build-buff-spec "'(abc (def))" 0 0) (make-key-spec (build-buff-spec "'(abc (def))" 0 0)
(build-buff-spec "'(abc (def))" 12 12) (build-buff-spec "'(abc (def))" 12 12)
(list '(right alt)) (list '(right alt))
@ -201,264 +242,243 @@
(list '(left alt)) (list '(left alt))
(list '(left alt))) (list '(left alt)))
|# |#
(build-open-bracket-spec "" 0 #\() (build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(f cond " 8 #\() (build-open-bracket-spec "(f cond " 8 #\()
(build-open-bracket-spec "(f let (" 8 #\() (build-open-bracket-spec "(f let (" 8 #\()
(build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(let (" 5 #\() (build-open-bracket-spec "(let (" 5 #\()
(build-open-bracket-spec "(provide/contract " 18 #\[) (build-open-bracket-spec "(provide/contract " 18 #\[)
(build-open-bracket-spec "(kond " 5 #\() (build-open-bracket-spec "(kond " 5 #\()
(build-open-bracket-spec "(cond " 5 #\[) (build-open-bracket-spec "(cond " 5 #\[)
(build-open-bracket-spec "(case-lambda " 13 #\[) (build-open-bracket-spec "(case-lambda " 13 #\[)
(build-open-bracket-spec "(let ([]" 8 #\[) (build-open-bracket-spec "(let ([]" 8 #\[)
(build-open-bracket-spec "(let ({}" 8 #\{) (build-open-bracket-spec "(let ({}" 8 #\{)
(build-open-bracket-spec "()" 2 #\() (build-open-bracket-spec "()" 2 #\()
(build-open-bracket-spec "(let (;;" 8 #\[) (build-open-bracket-spec "(let (;;" 8 #\[)
(build-open-bracket-spec ";" 1 #\[) (build-open-bracket-spec ";" 1 #\[)
(build-open-bracket-spec "\"" 1 #\[) (build-open-bracket-spec "\"" 1 #\[)
(build-open-bracket-spec "\"\"" 1 #\[) (build-open-bracket-spec "\"\"" 1 #\[)
(build-open-bracket-spec "||" 1 #\[) (build-open-bracket-spec "||" 1 #\[)
(build-open-bracket-spec "" 0 #\() (build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(new x% " 8 #\[) (build-open-bracket-spec "(new x% " 8 #\[)
(build-open-bracket-spec "#\\" 2 #\[) (build-open-bracket-spec "#\\" 2 #\[)
(build-open-bracket-spec "#\\a" 2 #\[) (build-open-bracket-spec "#\\a" 2 #\[)
(build-open-bracket-spec "(let ([let (" 12 #\() (build-open-bracket-spec "(let ([let (" 12 #\()
(build-open-bracket-spec "ab" 1 #\() (build-open-bracket-spec "ab" 1 #\()
(build-open-bracket-spec "|ab|" 2 #\[) (build-open-bracket-spec "|ab|" 2 #\[)
(build-open-bracket-spec "(let loop " 10 #\() (build-open-bracket-spec "(let loop " 10 #\()
(build-open-bracket-spec "(let loop (" 11 #\[) (build-open-bracket-spec "(let loop (" 11 #\[)
(build-open-bracket-spec "(case x " 8 #\[) (build-open-bracket-spec "(case x " 8 #\[)
(build-open-bracket-spec "(case x [" 9 #\() (build-open-bracket-spec "(case x [" 9 #\()
(build-open-bracket-spec "(let ([])(" 10 #\() (build-open-bracket-spec "(let ([])(" 10 #\()
(build-open-bracket-spec "(local " 7 #\[) (build-open-bracket-spec "(local " 7 #\[)
(build-open-bracket-spec "(local []" 9 #\() (build-open-bracket-spec "(local []" 9 #\()
;; test to show that multi-keystrokes works: ;; test to show that multi-keystrokes works:
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "" 0 0) (build-buff-spec "" 0 0)
(build-buff-spec "zx" 2 2) (build-buff-spec "zx" 2 2)
(list '((#\z) (#\x)))) (list '((#\z) (#\x))))
;; remove-enclosing-parens : ;; remove-enclosing-parens :
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(abc def)" 1 1) (build-buff-spec "(abc def)" 1 1)
(build-buff-spec "abc" 0 0) (build-buff-spec "abc" 0 0)
(list '((#\c control) (#\o control)))) (list '((#\c control) (#\o control))))
;; (is this the desired behavior?): ;; (is this the desired behavior?):
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(abc def)" 2 3) (build-buff-spec "(abc def)" 2 3)
(build-buff-spec "bc" 0 0) (build-buff-spec "bc" 0 0)
(list '((#\c control) (#\o control)))) (list '((#\c control) (#\o control))))
;; insert-()-pair : ;; insert-()-pair :
(make-key-spec (make-key-spec
(build-buff-spec "abc" 0 0) (build-buff-spec "abc" 0 0)
(build-buff-spec "()abc" 1 1) (build-buff-spec "()abc" 1 1)
(list '((escape) (#\())) (list '((escape) (#\()))
(list '((#\( meta))) (list '((#\( meta)))
(list '((escape) (#\()))) (list '((escape) (#\())))
(make-key-spec (make-key-spec
(build-buff-spec "abc" 0 2) (build-buff-spec "abc" 0 2)
(build-buff-spec "(ab)c" 1 1) (build-buff-spec "(ab)c" 1 1)
(list '((escape) (#\())) (list '((escape) (#\()))
(list '((#\( meta))) (list '((#\( meta)))
(list '((escape) (#\()))) (list '((escape) (#\())))
;; toggle-square-round-parens : ;; toggle-square-round-parens :
; () -> [] ; () -> []
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(a)" 0 0) (build-buff-spec "(a)" 0 0)
(build-buff-spec "[a]" 0 0) (build-buff-spec "[a]" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; [] -> () ; [] -> ()
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a]" 0 0) (build-buff-spec "[a]" 0 0)
(build-buff-spec "(a)" 0 0) (build-buff-spec "(a)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; enclosed sexps ; enclosed sexps
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a (def )b]" 0 0) (build-buff-spec "[a (def )b]" 0 0)
(build-buff-spec "(a (def )b)" 0 0) (build-buff-spec "(a (def )b)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; extra preceding whitespace ; extra preceding whitespace
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 0 0) (build-buff-spec " \n [a (def )b]" 0 0)
(build-buff-spec " \n (a (def )b)" 0 0) (build-buff-spec " \n (a (def )b)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; cursor not at beginning of buffer ; cursor not at beginning of buffer
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 1 1) (build-buff-spec " \n [a (def )b]" 1 1)
(build-buff-spec " \n (a (def )b)" 1 1) (build-buff-spec " \n (a (def )b)" 1 1)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; intervening non-paren sexp ; intervening non-paren sexp
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \nf [a (def )b]" 1 1) (build-buff-spec " \nf [a (def )b]" 1 1)
(build-buff-spec " \nf [a (def )b]" 1 1) (build-buff-spec " \nf [a (def )b]" 1 1)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
;; at end of buffer (hence sexp-forward returns #f): ;; at end of buffer (hence sexp-forward returns #f):
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a]" 3 3) (build-buff-spec "[a]" 3 3)
(build-buff-spec "[a]" 3 3) (build-buff-spec "[a]" 3 3)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "b" 1 1)
(list '((#\b))))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "|" 1 1)
(list '((#\|))))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "(" 1 1)
(list '((#\())))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec ")" 1 1)
(list '((#\)))))
;; needs to be in auto-adjut open paren mode
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "(" 1 1)
(list '((#\[))))
(ascii-art-box-spec "+" "═")
(ascii-art-box-spec "x" "x")
(ascii-art-box-spec "+-+" "═══")
(ascii-art-box-spec "+\n|\n+\n" "║\n║\n║\n")
(ascii-art-box-spec (string-append "+-+\n"
"| |\n"
"+-+\n")
(string-append "╔═╗\n"
"║ ║\n"
"╚═╝\n"))
(ascii-art-box-spec (string-append "+---+\n"
"| - |\n"
"|+ ||\n"
"+---+\n")
(string-append "╔═══╗\n"
"║ - ║\n"
"║+ |║\n"
"╚═══╝\n"))
(ascii-art-box-spec (string-append "+-+-+\n"
"| | |\n"
"+-+-+\n"
"| | |\n"
"+-+-+\n")
(string-append "╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))))
(define automatic-scheme-specs
(list (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "()" 1 1)
'(((#\())))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "[]" 1 1)
'(((#\[))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "{}" 1 1)
'(((#\{))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "\"\"" 1 1)
'(((#\"))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "||" 1 1)
'(((#\|))))))
(queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
(wait-for-frame "dummy to trick frame group")
;; test-key : key-spec ->
;; evaluates a test case represented as a key-spec
(define (test-key key-spec i)
(let* ([key-sequences
((case (system-type)
[(macos macosx) key-spec-macos]
[(unix) key-spec-unix]
[(windows) key-spec-windows])
key-spec)]
[before (key-spec-before key-spec)]
[after (key-spec-after key-spec)]
[process-key-sequence
(lambda (key-sequence)
(let ([text-expect (buff-spec-string after)]
[start-expect (buff-spec-start after)]
[end-expect (buff-spec-end after)])
(test (list key-sequence i)
(lambda (x) (equal? x (vector text-expect start-expect end-expect)))
`(let* ([qc (λ (t) (let ([c (make-channel)])
(queue-callback (λ () (channel-put c (t))))
(channel-get c)))]
[text (qc (λ () (send (get-top-level-focus-window) get-editor)))])
(qc (λ ()
(send text set-overwrite-mode ,(buff-spec-overwrite? before))
(send text erase)
(send text insert ,(buff-spec-string before))
(send text set-position ,(buff-spec-start before) ,(buff-spec-end before))))
,@(map (lambda (key) `(test:keystroke ',(car key) ',(cdr key)))
key-sequence)
(qc (λ ()
(vector (send text get-text)
(send text get-start-position)
(send text get-end-position))))))))])
(for-each process-key-sequence key-sequences)))
(define (test-specs frame-name frame-class specs)
(queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
(wait-for-frame frame-name)
(for ([spec (in-list specs)]
[i (in-naturals)])
(test-key spec i))
(queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
(make-key-spec/allplatforms (define old-paren-adjusting-prefs
(build-buff-spec "a" 0 0 #:overwrite? #t) (queue-sexp-to-mred `(list (preferences:get 'framework:fixup-open-parens)
(build-buff-spec "b" 1 1) (preferences:get 'framework:automatic-parens))))
(list '((#\b))))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(build-buff-spec "|" 1 1) (queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f))
(list '((#\|)))) (test-specs "global keybindings test" 'frame:text% global-specs)
(test-specs "scheme mode keybindings test"
'(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
scheme-specs)
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #t))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #f))
(test-specs "scheme mode automatic-parens on keybindings test"
'(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
automatic-scheme-specs)
(make-key-spec/allplatforms (queue-sexp-to-mred
(build-buff-spec "a" 0 0 #:overwrite? #t) `(begin (preferences:set 'framework:fixup-open-parens ,(list-ref old-paren-adjusting-prefs 0))
(build-buff-spec "(" 1 1) (preferences:set 'framework:automatic-parens ,(list-ref old-paren-adjusting-prefs 1))))
(list '((#\())))
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec ")" 1 1)
(list '((#\)))))
;; needs to be in auto-adjut open paren mode
(make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "(" 1 1)
(list '((#\[))))
(ascii-art-box-spec "+" "═")
(ascii-art-box-spec "x" "x")
(ascii-art-box-spec "+-+" "═══")
(ascii-art-box-spec "+\n|\n+\n" "║\n║\n║\n")
(ascii-art-box-spec (string-append "+-+\n"
"| |\n"
"+-+\n")
(string-append "╔═╗\n"
"║ ║\n"
"╚═╝\n"))
(ascii-art-box-spec (string-append "+---+\n"
"| - |\n"
"|+ ||\n"
"+---+\n")
(string-append "╔═══╗\n"
"║ - ║\n"
"║+ |║\n"
"╚═══╝\n"))
(ascii-art-box-spec (string-append "+-+-+\n"
"| | |\n"
"+-+-+\n"
"| | |\n"
"+-+-+\n")
(string-append "╔═╦═╗\n"
"║ ║ ║\n"
"╠═╬═╣\n"
"║ ║ ║\n"
"╚═╩═╝\n"))))
(define automatic-scheme-specs
(list (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "()" 1 1)
'(((#\())))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "[]" 1 1)
'(((#\[))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "{}" 1 1)
'(((#\{))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "\"\"" 1 1)
'(((#\"))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "||" 1 1)
'(((#\|))))))
(define (queue-callback/wait t)
(define c (make-channel))
(queue-callback (λ () (channel-put c (t))))
(channel-get c))
(define (test-specs frame-name frame-class specs)
(define f #f)
(queue-callback/wait
(λ ()
(set! f (make-object frame-class frame-name))
(send f show #t)))
(for ([key-spec (in-list specs)]
[i (in-naturals)])
(define key-sequences
((case (system-type)
[(macos macosx) key-spec-macos]
[(unix) key-spec-unix]
[(windows) key-spec-windows])
key-spec))
(define before (key-spec-before key-spec))
(define after (key-spec-after key-spec))
(for ([key-sequence (in-list key-sequences)])
(define text-expect (buff-spec-string after))
(define start-expect (buff-spec-start after))
(define end-expect (buff-spec-end after))
(queue-callback
(λ ()
(define frame (test:get-active-top-level-window))
(define text (send frame get-editor))
(send text set-overwrite-mode (buff-spec-overwrite? before))
(send text erase)
(send text insert (buff-spec-string before))
(send text set-position (buff-spec-start before) (buff-spec-end before))
(for ([key (in-list key-sequence)])
(define event (make-object key-event%))
(send event set-key-code (car key))
(send event set-time-stamp (current-milliseconds))
(for ([mod (in-list (cdr key))])
(cond
[(eq? mod 'alt) (send event set-alt-down #t)]
[(eq? mod 'control) (send event set-control-down #t)]
[(eq? mod 'meta) (send event set-meta-down #t)]
[(eq? mod 'shift) (send event set-shift-down #t)]
[(eq? mod 'noalt) (send event set-alt-down #f)]
[(eq? mod 'nocontrol) (send event set-control-down #f)]
[(eq? mod 'nometa) (send event set-meta-down #f)]
[(eq? mod 'noshift) (send event set-shift-down #f)]
[else (error 'keys.rkt "unknown key modifier: ~e" mod)]))
(send text on-local-char event))))
(check-equal?
(queue-callback/wait
(λ ()
(define frame (test:get-active-top-level-window))
(define text (send frame get-editor))
(vector (send text get-text)
(send text get-start-position)
(send text get-end-position))))
(vector text-expect start-expect end-expect)
(~s (list frame-name key-sequence i)))))
(queue-callback/wait (λ () (send f close))))
(with-private-prefs
(parameterize ([test:use-focus-table #t])
;; needs to be inside the test:use-focus-table setting
(parameterize ([current-eventspace (make-eventspace)])
(define dummy #f)
(queue-callback
(λ ()
(set! dummy (make-object frame:basic% "dummy to trick frame group"))
(send dummy show #t)))
(preferences:set 'framework:fixup-open-parens #t)
(preferences:set 'framework:automatic-parens #f)
(test-specs "global keybindings test" frame:text% global-specs)
(test-specs "racket mode keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
scheme-specs)
(preferences:set 'framework:automatic-parens #t)
(preferences:set 'framework:fixup-open-parens #f)
(test-specs "racket mode automatic-parens on keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
automatic-scheme-specs)
(queue-callback (λ () (send dummy show #f))))))

39
gui-test/framework/tests/number-snip.rkt
View File

@ -1,27 +1,22 @@
#lang racket/base #lang racket/base
(require "test-suite-utils.rkt" (require "test-suite-utils.rkt")
racket/contract
framework
file/convertible
rackunit)
(check-true (test
(let () 'number-snip-convert-text
(define x (λ (x) (or (equal? "1/2" x) (equal? "0.5" x)))
(convert (lambda ()
(queue-sexp-to-mred
`((dynamic-require 'file/convertible 'convert)
(number-snip:make-fraction-snip 1/2 #f) (number-snip:make-fraction-snip 1/2 #f)
'text 'text
#f)) #f))))
(or (equal? "1/2" x) (equal? "0.5" x))))
(test
(check-true 'number-snip-convert-png
(bytes? bytes?
(convert (lambda ()
(number-snip:make-fraction-snip 1/2 #f) (queue-sexp-to-mred
'png-bytes `((dynamic-require 'file/convertible 'convert)
#f))) (number-snip:make-fraction-snip 1/2 #f)
'png-bytes
(check-true (number-snip:is-number-snip? (number-snip:make-fraction-snip 3/2 #t))) #f))))
(check-false (number-snip:is-number-snip? 3/2))
(check-equal? 3/2 (number-snip:get-number (number-snip:make-fraction-snip 3/2 #t)))

285
gui-test/framework/tests/prefs.rkt
View File

@ -1,152 +1,141 @@
#lang racket/base #lang racket/base
(require framework/preferences (require "test-suite-utils.rkt")
racket/format
rackunit
racket/contract)
;(define ((check-equal? x) y) (equal? x y)) (module test racket/base)
(define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling) (define ((check-equal? x) y) (equal? x y))
(define default-test-sym 'plt:not-a-real-preference-default-test) (define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
(define default-test-sym 'plt:not-a-real-preference-default-test)
(shutdown-mred)
(test
'preference-unbound
(check-equal? 'passed)
`(with-handlers ([exn:unknown-preference?
(lambda (x)
'passed)])
(preferences:get ',pref-sym)))
(test 'preference-set-default/get
(check-equal? 'passed)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(test 'preference-set/get
(check-equal? 'new-pref)
`(begin (preferences:set ',pref-sym 'new-pref)
(preferences:get ',pref-sym)))
(define the-prefs-table (make-hash)) (test 'preference-marshalling
(parameterize ([preferences:low-level-put-preferences (check-equal? 'the-answer)
(λ (syms vals) `(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(for ([sym (in-list syms)] (preferences:set-un/marshall ',marshalling-pref-sym
[val (in-list vals)]) (lambda (f) (f))
(hash-set! the-prefs-table sym val)))] (lambda (v) (lambda () v)))
[preferences:low-level-get-preference (begin0 ((preferences:get ',marshalling-pref-sym))
(λ (sym [fail void]) (preferences:set ',marshalling-pref-sym (lambda () 2)))))
(hash-ref the-prefs-table sym fail))]) (shutdown-mred)
(test 'preference-marshalling
(check-equal? 2)
`(begin (preferences:set-default ',marshalling-pref-sym (lambda () 'the-answer) procedure?)
(preferences:set-un/marshall ',marshalling-pref-sym
(lambda (f) (f))
(lambda (v) (lambda () v)))
((preferences:get ',marshalling-pref-sym))))
(with-handlers ([eof-result? (lambda (x) (void))])
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
(exit:exit)
;; do this yield here so that exit:exit
;; actually exits on this interaction.
;; right now, exit:exit queue's a new event to exit
;; instead of just exiting immediately.
(yield (make-semaphore 0)))))
(test 'preference-get-after-restart
(check-equal? 'new-pref)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
(check-exn (test 'preference-no-set-default-stage1
exn:unknown-preference? (check-equal? 'stage1)
(λ () `(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:get pref-sym))) (preferences:set ',default-test-sym 'new-value)
'stage1))
(check-equal? (shutdown-mred)
(begin (test 'preference-no-set-default-stage2
(preferences:set-default pref-sym 'passed symbol?) (check-equal? 'stage2)
(preferences:get pref-sym)) `(begin 'stage2))
'passed) (shutdown-mred)
(test 'preference-no-set-default-stage3
(check-equal? (check-equal? 'new-value)
(begin (preferences:set pref-sym 'new-pref) `(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:get pref-sym)) (preferences:get ',default-test-sym)))
'new-pref)
(test 'preference-add-callback
(check-true (preferences:default-set? pref-sym)) (check-equal? 2)
(check-false (preferences:default-set? 'unknown-preference)) `(begin
(check-false (begin (let ([x 1])
(preferences:add-callback 'pref-with-only-callback-set void) (define remove-it (preferences:add-callback ',default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:default-set? 'pref-with-only-callback-set))) (preferences:set ',default-test-sym 'xyz)
(remove-it)
(check-equal? (preferences:set ',default-test-sym 'pdq)
(begin (preferences:set-default marshalling-pref-sym (lambda () 'the-answer) procedure?) x)))
(preferences:set-un/marshall marshalling-pref-sym
(lambda (f) (f)) (test 'preference-add-weak-callback
(lambda (v) (lambda () v))) (check-equal? 2)
(begin0 ((preferences:get marshalling-pref-sym)) `(begin
(preferences:set marshalling-pref-sym (lambda () 2)))) (let ([x 1])
'the-answer) (define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(check-equal? ((preferences:get marshalling-pref-sym)) 2) (preferences:set ',default-test-sym 'xyz)
(remove-it)
;; make sure the preference actually got "written out" (preferences:set ',default-test-sym 'pdq)
(check-equal? (hash-ref the-prefs-table x)))
(string->symbol (~a "plt:framework-pref:" pref-sym)))
'new-pref) (test 'preference-add-weak-callback2
(check-equal? 3)
(let () `(begin
(preferences:set-default 'unmarshalling-enumerate-test '() (listof exact-nonnegative-integer?)) (let ([x 1])
(preferences:set-un/marshall 'unmarshalling-enumerate-test (define f (λ (a b) (set! x (+ x 1))))
(λ (lon) (~s lon)) (unless (zero? (random 1)) (set! f 'not-a-proc)) ;; try to stop inlining
(λ (s) (read (open-input-string s)))) (define remove-it (preferences:add-callback ',default-test-sym f #t))
(collect-garbage) (collect-garbage) (collect-garbage)
;; simulate a value having been saved from some prior run of the preferences library (preferences:set ',default-test-sym 'xyz)
(hash-set! the-prefs-table 'plt:framework-pref:unmarshalling-enumerate-test (remove-it)
(~s '(1 2 3 4 5))) (preferences:set ',default-test-sym 'pdq)
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
(check-equal? (preferences:get 'unmarshalling-enumerate-test) '(1 2 3 4 5))) x)))
(check-equal? (test 'preference-weak-callback-is-weak
(let ([x 1]) (check-equal? #t)
(preferences:set-default default-test-sym 'default symbol?) `(begin
(define remove-it (preferences:add-callback default-test-sym (λ (a b) (set! x (+ x 1))))) (let ([x 1])
(preferences:set default-test-sym 'xyz) (define f (λ (a b) (set! x (+ x 1))))
(remove-it) (define wb (make-weak-box f))
(preferences:set default-test-sym 'pdq) (define remove-it (preferences:add-callback ',default-test-sym f #t))
x) (set! f #f)
2) (begin0
(let loop ([n 10])
(check-equal? (cond
(let ([x 1]) [(not (weak-box-value wb)) #t]
(define remove-it (preferences:add-callback 'callback-before-delete (λ (a b) (set! x (+ x 1))))) [(zero? n) 'f-still-alive]
(preferences:set-default 'callback-before-delete 'default symbol?) [else
(preferences:set 'callback-before-delete 'xyz) (collect-garbage)
(remove-it) (loop (- n 1))]))
(preferences:set 'callback-before-delete 'pdq) (remove-it)))))
x)
2) (test 'dialog-appears
(check-equal? 'passed)
(check-equal? (lambda ()
(let ([x 1]) (queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(define f (λ (a b) (set! x (+ x 1)))) (preferences:show-dialog)))
(define remove-it (preferences:add-callback default-test-sym f #t)) (wait-for-frame "Preferences")
(preferences:set default-test-sym 'xyz) (queue-sexp-to-mred '(begin (preferences:hide-dialog)
(remove-it) (let ([f (get-top-level-focus-window)])
(preferences:set default-test-sym 'pdq) (if f
x) (if (string=? "Preferences" (send f get-label))
2) 'failed
'passed)
(check-equal? 'passed))))))
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(unless (zero? (random 1)) (set! f 'not-a-proc))
(define remove-it (preferences:add-callback default-test-sym f #t))
(collect-garbage) (collect-garbage) (collect-garbage)
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
(f 'a 'b) ;; make sure safe-for-space doesn't free 'f' earlier
x)
3)
(check-equal?
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define wb (make-weak-box f))
(define remove-it (preferences:add-callback default-test-sym f #t))
(set! f #f)
(let loop ([n 10])
(cond
[(not (weak-box-value wb)) #t]
[(zero? n) 'f-still-alive]
[else
(collect-garbage)
(loop (- n 1))]))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
1)
(let ()
(hash-set! the-prefs-table
'plt:framework-pref:preferences-aliases-test:1
"1")
(preferences:set-default 'preferences-aliases-test
0
exact-nonnegative-integer?
#:aliases '(preferences-aliases-test:1)
#:rewrite-aliases (list (λ (v) (read (open-input-string v)))))
(check-equal? (preferences:get 'preferences-aliases-test) 1))
(let ()
(preferences:set-default 'snapshot-test 0 number?)
(preferences:set 'snapshot-test 11)
(define snap (preferences:get-prefs-snapshot))
(preferences:set 'snapshot-test 12)
(preferences:restore-prefs-snapshot snap)
(check-equal? (preferences:get 'snapshot-test) 11)))

25
gui-test/framework/tests/private/here-util.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require framework/private/focus-table
racket/gui/base
racket/class)
(provide wait-for-frame)
(define (wait-for/here test)
(define timeout 10)
(define pause-time 1/2)
(let loop ([n (ceiling (/ timeout pause-time))])
(if (zero? n)
(error 'wait-for "after ~a seconds, ~s didn't come true" timeout test)
(unless (test)
(sleep pause-time)
(loop (- n 1))))))
(define (wait-for-frame name [eventspace (current-eventspace)])
(define (check-for-frame)
(for/or ([frame (in-list (frame:lookup-focus-table eventspace))])
(and (equal? name (send frame get-label))
frame)))
(wait-for/here
(procedure-rename check-for-frame
(string->symbol (format "check-for-frame-named-\"~a\"" name)))))

51
gui-test/framework/tests/private/util.rkt
View File

@ -1,51 +0,0 @@
#lang racket/base
(require framework/private/focus-table
framework/preferences
racket/gui/base
racket/class
(for-syntax racket/base))
(provide wait-for-frame wait-for/here
with-private-prefs)
(define (wait-for/here test)
(define timeout 10)
(define pause-time 1/2)
(let loop ([n (ceiling (/ timeout pause-time))])
(if (zero? n)
(error 'wait-for "after ~a seconds, ~s didn't come true" timeout test)
(unless (test)
(sleep pause-time)
(loop (- n 1))))))
(define (wait-for-frame name [eventspace (current-eventspace)])
(define (check-for-frame)
(for/or ([frame (in-list (frame:lookup-focus-table eventspace))])
(and (equal? name (send frame get-label))
frame)))
(wait-for/here
(procedure-rename check-for-frame
(string->symbol (format "check-for-frame-named-\"~a\"" name)))))
(define-syntax (with-private-prefs stx)
(syntax-case stx ()
[(_ e1 e2 ...)
#'(with-private-prefs/proc (λ () e1 e2 ...))]))
(define (with-private-prefs/proc t)
(define pref-ht (make-hash))
(parameterize ([preferences:low-level-get-preference
(λ (sym [fail (λ () #f)])
(hash-ref pref-ht sym fail))]
[preferences:low-level-put-preferences
(λ (syms vals)
(for ([sym (in-list syms)]
[val (in-list vals)])
(hash-set! pref-ht sym val)))])
;; make sure we're back to a clean preferences state
;; and the parameterize above ensure that we won't
;; look at the disk so together this should mean
;; no interference between different concurrent tests
(preferences:restore-defaults)
(t)))

1497
gui-test/framework/tests/text.rkt
View File

File diff suppressed because it is too large Load Diff

2
gui-test/tests/gracket/item.rkt
View File

@ -2214,7 +2214,7 @@
(make-object button% "Toggle" f (lambda (b e) (make-object button% "Toggle" f (lambda (b e)
(send f on-toolbar-button-click))) (send f on-toolbar-button-click)))
(make-object message% "Mac OS: toolbar button also toggles" f) (make-object message% "Mac OS X: toolbar button also toggles" f)
(send f show #t)) (send f show #t))
;---------------------------------------------------------------------- ;----------------------------------------------------------------------