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
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["matrix-snip.scrbl"]
@include-section["snip-canvas.scrbl"]
@include-section["syntax-browser.scrbl"]
@include-section["tex-table.scrbl"]
@include-section["terminal.scrbl"]

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

@ -8,7 +8,7 @@
@defclass[switchable-button% canvas% ()]{
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
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
@racket[get-token] is @racket['symbol] and this value is a string
then the value is used to differentiate between symbols and keywords
for the purpose of coloring and formatting, configurable from DrRacket's
preference's editing menu.}
for the purpose of coloring and formatting, configurable from DrRacket's preference's editing menu.}
@item{A symbol describing the type of the token. This symbol is
transformed into a style-name via the @racket[token-sym->style] argument.
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
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
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].}
@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.}]
@ -64,12 +63,7 @@
The offset given to @racket[get-token] can be added
to the position of the input port to obtain absolute coordinates within a
text stream. The extra two results are
@itemize[@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.}
@item{a new mode;
@itemize[@item{a new mode;
The mode argument allows @racket[get-token] to communicate
information from earlier parsing to later. When @racket[get-token] is
called for the beginning on a stream, the mode argument is @racket[#f];
@ -89,7 +83,12 @@
The mode should not be a mutable
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]
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:
@itemize[
@ -188,14 +187,11 @@
background after the call to @racket[thaw-colorer] returns.
}
@defmethod[(reset-region (start exact-nonnegative-integer?)
(end (or/c exact-nonnegative-integer? 'end))) void?]{
@defmethod[(reset-region (start exact-nonnegative-integer?) (end (or/c exact-nonnegative-integer? 'end))) void?]{
Set the region of the text that is tokenized.
}
@defmethod[(reset-regions [regions (listof (list/c exact-nonnegative-integer?
(or/c exact-nonnegative-integer? 'end)))])
void?]{
@defmethod[(reset-regions (regions (listof (list/c exact-nonnegative-integer? (or/c exact-nonnegative-integer? 'end))))) void?]{
Sets the currently active regions to be @racket[regions].
}
@ -241,8 +237,7 @@
spell checking is disabled, returns @racket[#f].
}
@defmethod[(get-regions)
(listof (list/c exact-nonnegative-integer? (or/c exact-nonnegative-integer? 'end)))]{
@defmethod[(get-regions) (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
editor.
@ -260,8 +255,7 @@
Must only be called while the tokenizer is started.
}
@defmethod[(backward-match [position exact-nonnegative-integer?]
[cutoff exact-nonnegative-integer?])
@defmethod[(backward-match [position exact-nonnegative-integer?] [cutoff exact-nonnegative-integer?])
(or/c exact-nonnegative-integer? #f)]{
Skip all consecutive whitespaces and comments (using
@ -272,8 +266,7 @@
Must only be called while the tokenizer is started.
}
@defmethod[(backward-containing-sexp [position exact-nonnegative-integer?]
[cutoff exact-nonnegative-integer?])
@defmethod[(backward-containing-sexp [position exact-nonnegative-integer?] [cutoff exact-nonnegative-integer?])
(or/c exact-nonnegative-integer? #f)]{
Return the starting position of the interior of the (non-atomic)
@ -376,15 +369,7 @@
@defclass[color:text% (color:text-mixin text:keymap%) ()]{}
@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.
}
}
@definterface[color:text-mode<%> ()]{}
@defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-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
@(require scribble/manual scribble/extract)
@(require (for-label framework racket/gui racket/contract/base))
@(require (for-label framework racket/gui))
@title{Text}
@definterface[text:basic<%> (editor:basic<%> text%)]{
@ -139,43 +139,24 @@
}
@defmethod[(move/copy-to-edit [dest-text (is-a?/c text%)]
[start natural?]
[end (and/c natural? (>=/c start))]
[dest-pos natural?]
[start exact-integer?]
[end exact-integer?]
[dest-pos exact-integer?]
[#:try-to-move? try-to-move? boolean? #t])
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]
starting at location @racket[dest-pos]. If @racket[start] and @racket[end]
are equal then nothing is moved or copied.
starting at location @racket[dest-pos].
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
@racket[#t] and @racket[dest-pos] is between @racket[start] and @racket[end]
then @racket[this] is unchanged.
If @racket[try-to-move] is @racket[#t], then the snips are removed;
and if it is @racket[#f], then they are copied.
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
@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%))))]{
The result of this method is used as the initial autowrap bitmap. Override
@ -558,7 +539,7 @@
@definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
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?]
[replace-mode? boolean?]
[notify-frame? boolean?])
@ -595,40 +576,22 @@
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
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)]{
Returns the position of the nearest search hit that comes after the
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?]{
This method is ignored. (The next replacement start is now
tracked via the @method[text% after-set-position] method.)
}
@defmethod[(finish-pending-search-work) void?]{
Finishes any pending work in computing and 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[(finish-pending-search-work) void?]{
Finishes any pending work in computing and
drawing the search bubbles.
}
@defmethod[(get-search-bubbles)
(listof (list/c (cons/c number? number?)
@ -640,12 +603,6 @@
the range of the bubble and the symbol is the color of the
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.
}
}
@ -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?))]{
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;
under Windows and X, the character
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
@xmethod[top-level-window<%> on-traverse-char] is concerned),
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
string), it is specially parsed; on Windows and Unix, the character
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
digit. The user can effectively click the button by typing the
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
@racket[label] before it is displayed for the control; a @litchar{&&}
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
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
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
@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
@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]
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
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
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
@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
@ -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
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
@racket[gl-config%] specification that is adjusted to high-resolution
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])
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
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

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.
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
format. New format names can be used to communicate application- and
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
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].
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?])
(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.
See
@ -92,7 +92,7 @@ Returns @racket[#t] if @racket[owner] currently owns the clipboard,
[time exact-integer?])
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).
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],
it specifies an initial size for the dialog (in pixels) assuming that
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.
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)}
@item{@racket['resize-border] --- adds a resizeable border around the
window (Windows), ability to resize the window (Mac OS), or grow
box in the bottom right corner (older Mac OS)}
window (Windows), ability to resize the window (Mac OS X), or grow
box in the bottom right corner (older Mac OS X)}
@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
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
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
directory, which is a directory with a special suffix (e.g.,
``.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
character. For example, @racket["*.jp*g;*.png"].
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"]
are extracted from a @racket["*.foo;*.bar;*.baz*"] pattern), and files
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
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
user does not supply one. If @racket[filters] contains as
@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 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],
@racket[extension] is not @racket[""], and
@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
@racket[get-file], except that only @racket['common] or @racket['enter-packages] can be
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
package. A package is a directory with a special suffix (e.g.,
``.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
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
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).}
@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.}
]

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)
boolean?])]{
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].
@ -187,7 +187,8 @@ First case:
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
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
operations, such as inserts, deletes, and font changes. Install an
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<%>
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
(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
into the editor, but no cut-and-paste or undo operations are
available. We can support all of the standard operations on an editor
via the menu bar:
into the editor, but no cut-and-paste operations are available. We
can support all of the standard operations on an editor via the
menu bar:
@racketblock[
(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]))
(append-editor-operation-menu-items m-edit #f)
(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
the user can even set font styles. The editor is created with no undo
history stack, @method[editor<%> set-max-undo-history] is used to set
a non-zero stack, so undo operations can be recorded. The user can
also insert an embedded editor by selecting @onscreen{Insert Text}
from the @onscreen{Edit} menu; after selecting the menu item, a box
appears in the editor with the caret inside. Typing with the caret in
the box stretches the box as text is added, and font operations apply
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.
Now, the standard cut and paste operations work, and the user can even
set font styles. The user can also insert an embedded editor by
selecting @onscreen{Insert Text} from the @onscreen{Edit} menu; after
selecting the menu item, a box appears in the editor with the caret
inside. Typing with the caret in the box stretches the box as text is
added, and font operations apply 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
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
represented with a useful string determined by the @techlink{item}'s
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
``flattened'' because the editor's @techlink{item}s have been reduced
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)
boolean?]{
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[#f] otherwise.
@ -101,7 +101,7 @@ Returns the top level window in the current eventspace that is visible
boolean?])]{
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.
}
@ -111,7 +111,7 @@ has no effect.
[(special-option-key)
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%
get-key-code] and @method[key-event% get-other-altgr-key-code]
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.
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
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
@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].
@ -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
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[small-control-font]. On Windows and Unix, it is the same size
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
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
(Windows, Mac OS, Unix)}
(Windows, Mac OS X, Unix)}
@item{@racket['no-system-menu] --- omits the system menu
(Windows)}
@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]}
@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)}
@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
is combined with @racket['no-caption], then showing the frame does
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
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
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
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
frame has been put in fullscreen mode} @elem{@method[frame% is-fullscreened?]}]
On Mac OS, the @racket[frame%] must be created with the style
@racket['fullscreen-button] for fullscreen mode to work, and Mac OS
On Mac OS X, the @racket[frame%] must be created with the style
@racket['fullscreen-button] for fullscreen mode to work, and Mac OS X
10.7 or later is required.
@history[#:added "1.9"
#: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)
(or/c (is-a?/c menu-bar%) #f)]{
@ -184,7 +184,7 @@ otherwise.
@defmethod[(is-maximized?)
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
@racket[#f].
@ -194,7 +194,7 @@ maximized, @racket[#f] otherwise. On Unix, the result is always
void?]{
@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
cannot be maximized or restored.
@ -216,7 +216,7 @@ If @racket[maximize?] is @racket[#f], the window is restored, otherwise
void?])]{
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
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)
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.
}

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
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
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].
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?]{
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].}
@ -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
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
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
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.
@ -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]
@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
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].
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
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.
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.
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
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
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
@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)
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
a Meta press (see
@method[key-event% get-meta-down]).
@ -63,7 +63,7 @@ Returns @racket[#t] if the Caps Lock key was on for the event.
boolean?]{
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
@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
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}
@ -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
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
case of Control, Caps Lock is used normally if special handling is
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)
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
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
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 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.
}
@ -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])
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
(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.
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
@method[key-event% get-control-down] for the event reports
@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])
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.
}

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

@ -32,7 +32,7 @@ Creates an empty keymap.
}
@defmethod[(add-function [name string?]
[func (any/c (is-a?/c event%) . -> . any)])
[func (any/c (is-a?/c event%) . -> . any/c)])
void?]{
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{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]}
@item{@litchar{d:} --- Mac OS: Command}
@item{@litchar{d:} --- Mac OS X: Command}
@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
@litchar{s:a} are both treated as @litchar{s:A}. However, 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
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
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
focus, the mnemonic characters are used for navigation without Alt. A
@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
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
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

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],
@indexed-racket['caution], or @indexed-racket['stop] symbol for
@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
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)
(= 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
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
@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
@racket['(ctl)], but the default can be changed through the
@Resource{defaultMenuPrefix} low-level preference (see
@ -197,7 +197,7 @@ follows:
@item{@racket['win32] (Windows)}
@item{@racket['cocoa] (Mac OS)}
@item{@racket['cocoa] (Mac OS X)}
@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
'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
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
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
internally contains four times as many pixels as requested by
@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
@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
Quicktime. To play @filepath{.wav} files, Quicktime 3.0 (compatible
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
@onscreen{OK} and @onscreen{Cancel} buttons should place the
@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<%>)]{

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['middle-down] --- middle mouse button pressed}
@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-up] --- right mouse button released (Mac OS: release 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 X: release with control key 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)
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
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.
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
@method[mouse-event% get-control-down] for the event reports
@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)
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?]{
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.
}
@ -204,7 +205,7 @@ Returns @racket[#t] if the Mod5 (Unix) key was down for the event.
boolean?]{
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.
}
@ -254,7 +255,7 @@ Returns @racket[#t] if this was a moving event (whether a button is
@defmethod[(set-alt-down [down? any/c])
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
(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.
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
@method[mouse-event% get-control-down] for the event reports
@racket[#f].
@ -300,7 +301,7 @@ the event.
@defmethod[(set-meta-down [down? any/c])
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.
}
@ -309,7 +310,7 @@ Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key
void?]{
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?]{
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.
}

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

@ -553,7 +553,7 @@ Pastes.
@methspec{
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
not call this method directly; instead, call @method[editor<%>
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[
@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['ctl] --- Control}
@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

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

@ -119,5 +119,5 @@ directory.
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?)
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
application menus. For any other system or eventspace, the result is
@racket[#f].
This procedure is intended for use in deciding whether to include a
@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
@method[top-level-window<%> on-exit] method, the @onscreen{About} menu item is controlled by
@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?)
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
when no frame is visible. For any other system or eventspace, the
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
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).
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)])
void?])]{
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
application-handled file or drags a file onto the application'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
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.
If the current eventspace is not the initial eventspace, this
@ -91,7 +92,7 @@ or has no effect (when called with a handler).
void?])]{
When the current eventspace is the initial eventspace, this procedure
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
a callback). If the handler is set to @racket[#f], the
@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
retrieves or installs a thunk that is called when the user requests
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
a callback). If the result of the thunk is @racket[#f], then the
operating system is explicitly notified that the application does not
@ -138,7 +139,7 @@ or has no effect (when called with a handler).
void?])]{
When the current eventspace is the initial eventspace, this procedure
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
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{
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
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]
[start (or/c exact-nonnegative-integer? 'start) 'start]
[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]
[start (or/c exact-nonnegative-integer? 'start) 'start]
[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.
}
@defmethod[(find-string-all [str non-empty-string?]
@defmethod[(find-string-all [str string?]
[direction (or/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? 'start) 'start]
[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]
[start (or/c exact-nonnegative-integer? 'start) 'start]
[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
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
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
words, floating frames act as an extension of the active non-frame
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
system requests that the application shut down (e.g., when the
@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
if the window's @method[top-level-window<%> can-exit?] method first
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
events and alphanumeric key events when the Meta (Unix) or Alt
(Windows) key is not pressed (and all alphanumeric events on
Mac OS)}
Mac OS X)}
@item{@racket[text-field%], @racket['multiple] style --- all
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
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
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
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
point, rather than terminating the program or escaping past an enclosing
@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}
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
drawing units are used consistently for window sizes, child window
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
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<%>
move] considers @math{(0, 0)} to be below the menu bar. See also
@racket[get-display-left-top-inset].
@ -93,7 +93,7 @@ on the platform:
@item{Windows: @tt{HWND}}
@item{Mac OS: @tt{NSView}}
@item{Mac OS X: @tt{NSView}}
@item{Unix: @tt{GtkWidget}}
@ -139,7 +139,7 @@ platform:
@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}
@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
@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
application's icon, the main thread's application file handler is
called (see

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

@ -495,7 +495,7 @@ 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
mode.

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

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

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

@ -193,39 +193,23 @@
(proc-doc/names
number-snip:make-repeating-decimal-snip
(-> real? boolean? number-snip:is-number-snip?)
(real? boolean? . -> . (is-a?/c snip%))
(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.
See also @racket[number-snip:make-fraction-snip].})
(proc-doc/names
number-snip:make-fraction-snip
(-> real? boolean? number-snip:is-number-snip?)
(real? boolean? . -> . (is-a?/c snip%))
(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
shown in the decimal state.
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
comment-box:snipclass
(is-a?/c snip-class%)

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

@ -28,10 +28,7 @@ the state transitions / contracts are:
(require scribble/srcdoc
racket/contract/base racket/file)
(require/doc racket/base
scribble/manual
scribble/example
(for-label racket/serialize))
(require/doc racket/base scribble/manual (for-label racket/serialize))
(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)))
;; 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
(define marshall-unmarshall (make-hasheq))
;; callbacks : sym -o> (listof (sym TST -> boolean))
(define callbacks (make-hasheq))
;; defaults : hash-table[sym -o> default]
(struct preferences:layer (preferences marshall-unmarshall callbacks defaults prev))
(define defaults (make-hasheq))
(define (preferences:new-layer prev)
(preferences:layer (make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq) prev))
(define preferences:current-layer (make-parameter (preferences:new-layer #f)))
(define (find-layer 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)))
;; these four functions determine the state of a preference
(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
(define (preferences:default-set? pref) (hash-has-key? defaults pref))
(define (pref-can-init? pref)
(not (hash-has-key? preferences pref)))
;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
(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)))
;; 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
(define none (gensym 'none))
@ -91,53 +80,45 @@ the state transitions / contracts are:
;; return the current value of the preference `p'
;; exported
(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))
(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
;; it's not there, use the default
[(eq? v none)
(define defaults (preferences:layer-defaults pref-state))
;; try to read the preference from the preferences file
(define marshalled-v (read-pref-from-file (hash-ref defaults p) p))
(define default-info (hash-ref defaults p))
(define the-default-value (default-value default-info))
(define v (if (eq? marshalled-v none)
;; no value read, take the default value
the-default-value
;; found a saved value, unmarshall it
(unmarshall-pref pref-state p marshalled-v
(default-checker default-info)
the-default-value)))
;; set the value in the preferences table for easier reference
;; and so we know it has been read from the disk
;; (and thus setting the marshaller after this is no good)
(hash-set! preferences p v)
v]
;; oth. it is found, so we can just return it
[else v]))
[(preferences:default-set? p)
(let* (;; try to read the preference from the preferences file
[v (read-pref-from-file p)]
[v (if (eq? v none)
;; no value read, take the default value
(default-value (hash-ref defaults p))
;; found a saved value, unmarshall it
(unmarshall-pref p v))])
;; set the value for future reference and return it
(hash-set! preferences p v)
v)]
[(not (preferences:default-set? p))
(raise-unknown-preference-error
'preferences:get
"tried to get a preference but no default set for ~e"
p)]))
;; read-pref-from-file : symbol -> (or/c any none)
;; reads the preference saved in the low-level preferences
;; file, first checking 'p' and then checking the aliases (in order)
(define (read-pref-from-file defaults p)
(let loop ([syms (cons p (default-aliases defaults))]
[rewriters (cons values (default-rewrite-aliases defaults))])
(cond
[(null? syms) none]
[else
(let/ec k
((car rewriters)
((preferences:low-level-get-preference)
(add-pref-prefix (car syms))
(lambda () (k (loop (cdr syms) (cdr rewriters)))))))])))
(define (read-pref-from-file p)
(let ([defaults (hash-ref defaults p)])
(let loop ([syms (cons p (default-aliases defaults))]
[rewriters (cons values (default-rewrite-aliases defaults))])
(cond
[(null? syms) none]
[else
(let/ec k
((car rewriters)
((preferences:low-level-get-preference)
(add-pref-prefix (car syms))
(lambda () (k (loop (cdr syms) (cdr rewriters)))))))]))))
;; set : symbol any -> void
;; updates the preference
@ -152,37 +133,37 @@ the state transitions / contracts are:
(λ ()
(call-pref-save-callbacks #t))
(λ ()
(for ([p (in-list ps)]
[value (in-list values)])
(define pref-state (find-layer p))
(cond
[pref-state
(define default (hash-ref (preferences:layer-defaults pref-state) p))
(define checker? (default-checker default))
(unless (checker? value)
(error 'preferences:set
(string-append
"new value doesn't satisfy preferences:set-default predicate\n"
" pref symbol: ~e\n"
" given: ~e\n"
" predicate: ~e")
p value checker?))
(check-callbacks pref-state p value)
(hash-set! (preferences:layer-preferences pref-state) p value)]
[else
(raise-unknown-preference-error
'preferences:set
(string-append
"cannot set preference before setting default"
" pref symbol: ~e\n"
" given: ~e")
p
value)]))
(for-each
(λ (p value)
(cond
[(preferences:default-set? p)
(define default (hash-ref defaults p))
(define checker? (default-checker default))
(unless (checker? value)
(error 'preferences:set
(string-append
"new value doesn't satisfy preferences:set-default predicate\n"
" pref sym: ~v\n"
" given: ~e\n"
" predicate: ~e")
p value checker?))
(check-callbacks p value)
(hash-set! preferences p value)]
[(not (preferences:default-set? p))
(raise-unknown-preference-error
'preferences:set
(string-append
"cannot set preference before setting default"
" pref sym: ~e\n"
" given: ~e")
p
value)]))
ps values)
((preferences:low-level-put-preferences)
(map add-pref-prefix ps)
(for/list ([p (in-list ps)]
[value (in-list values)])
(marshall-pref p value)))
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(λ ()
(call-pref-save-callbacks #f))))
@ -220,36 +201,33 @@ the state transitions / contracts are:
(current-continuation-marks))))
;; add-callback : sym (-> void) -> void
(define (preferences:add-callback p callback [weak? #f])
(define pref-state (or (find-layer p) (preferences:current-layer)))
(define callbacks (preferences:layer-callbacks pref-state))
(define new-cb
(make-pref-callback (if weak?
(impersonator-ephemeron callback)
callback)))
(hash-set! callbacks
p
(append
(hash-ref callbacks p '())
(list new-cb)))
(λ ()
(hash-set!
callbacks
p
(let loop ([callbacks (hash-ref callbacks p '())])
(cond
[(null? callbacks) '()]
[else
(let ([callback (car callbacks)])
(cond
[(eq? callback new-cb)
(loop (cdr callbacks))]
[else
(cons (car callbacks) (loop (cdr callbacks)))]))])))))
(define preferences:add-callback
(lambda (p callback [weak? #f])
(let ([new-cb (make-pref-callback (if weak?
(impersonator-ephemeron callback)
callback))])
(hash-set! callbacks
p
(append
(hash-ref callbacks p '())
(list new-cb)))
(λ ()
(hash-set!
callbacks
p
(let loop ([callbacks (hash-ref callbacks p '())])
(cond
[(null? callbacks) '()]
[else
(let ([callback (car callbacks)])
(cond
[(eq? callback new-cb)
(loop (cdr callbacks))]
[else
(cons (car callbacks) (loop (cdr callbacks)))]))])))))))
;; check-callbacks : pref-state sym val -> void
(define (check-callbacks pref-state p value)
(define callbacks (preferences:layer-callbacks pref-state))
;; check-callbacks : sym val -> void
(define (check-callbacks p value)
(define new-callbacks
(let loop ([callbacks (hash-ref callbacks p '())])
(cond
@ -274,137 +252,106 @@ the state transitions / contracts are:
(hash-set! callbacks p new-callbacks)))
(define (preferences:set-un/marshall p marshall unmarshall)
(define pref-state (find-layer p))
(cond
[pref-state
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
(define pref-un/marshall-set? (hash-ref marshall-unmarshall p #f))
(define pref-can-init? (not (hash-has-key? (preferences:layer-preferences pref-state) p)))
(cond
[(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
[(and (preferences:default-set? p)
(not (pref-un/marshall-set? p))
(pref-can-init? p))
(hash-set! marshall-unmarshall p (make-un/marshall marshall unmarshall))]
[(not (preferences:default-set? p))
(error 'preferences:set-un/marshall
"must call preferences:set-default for ~s before calling set-un/marshall for ~s"
p p)]))
"must call set-default for ~s before calling set-un/marshall for ~s"
p p)]
[(pref-un/marshall-set? p)
(error 'preferences:set-un/marshall
"already set un/marshall for ~e"
p)]
[(not (pref-can-init? p))
(error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
(define (preferences:restore-defaults)
(hash-for-each
defaults
(λ (p def) (preferences:set p (default-value def)))))
;; set-default : (sym TST (TST -> boolean) -> void
(define (preferences:set-default p default-value checker
#:aliases [aliases '()]
#:rewrite-aliases [rewrite-aliases (map (λ (x) values) aliases)])
(define pref-state (or (find-layer p) (preferences:current-layer)))
(define defaults (preferences:layer-defaults pref-state))
(when (hash-has-key? defaults p)
(error 'preferences:set-default
(string-append
"preferences default already set\n"
" pref symbol: ~e\n"
" default: ~e\n"
" checker: ~e")
p default-value checker))
(unless (checker default-value)
(error 'preferences:set-default
(string-append
"checker doesn't match default\n"
" pref symbol: ~e\n"
" default: ~e\n"
" checker: ~e")
p default-value checker))
(unless (= (length aliases) (length rewrite-aliases))
(error 'preferences:set-default
(string-append
"expected equal length lists for the #:aliases"
" and #:rewrite-aliases arguments, got ~e and ~e")
aliases rewrite-aliases))
(hash-set! defaults p (make-default default-value checker aliases rewrite-aliases)))
#:rewrite-aliases [rewrite-aliases (map (lambda (x) values) aliases)])
(cond
[(and (not (preferences:default-set? p))
(pref-can-init? p))
(define default-okay? (checker default-value))
(unless default-okay?
(error 'set-default
(string-append
"checker doesn't match default\n"
" default: ~e\n"
" pref sym: ~e\n"
" checker: ~e")
p default-value checker))
(unless (= (length aliases) (length rewrite-aliases))
(error 'preferences:set-default
"expected equal length lists for the #:aliases and #:rewrite-aliases arguments, got ~e and ~e"
aliases rewrite-aliases))
(hash-set! defaults p (make-default default-value checker aliases rewrite-aliases))]
[(not (pref-can-init? p))
(error 'preferences:set-default
"tried to call set-default for preference ~e but it cannot be configured any more"
p)]
[(preferences:default-set? p)
(error 'preferences:set-default
"preferences default already set for ~e" p)]
[(not (pref-can-init? p))
(error 'preferences:set-default
"can no longer set the default for ~e" p)]))
;; marshall-pref : symbol any -> (list symbol printable)
(define (marshall-pref p value)
(define pref-state (find-layer p))
(let/ec k
(define marshaller
(un/marshall-marshall
(hash-ref (preferences:layer-marshall-unmarshall pref-state)
p
(λ () (k value)))))
(marshaller value)))
(let* ([marshaller
(un/marshall-marshall
(hash-ref marshall-unmarshall p (λ () (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
(define (unmarshall-pref pref-state p data the-checker the-default-value)
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
(define un/marshall (hash-ref marshall-unmarshall p #f))
(define result
(if un/marshall
((un/marshall-unmarshall un/marshall) data)
data))
(if (the-checker result)
result
the-default-value))
(define (unmarshall-pref p data)
(let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
[result (if un/marshall
((un/marshall-unmarshall un/marshall) data)
data)]
[default (hash-ref defaults p)])
(if ((default-checker default) result)
result
(default-value default))))
;; copy-pref-value : sym any -> any
;; uses the marshalling code to copy a preference. If there
;; is not marshaller set, then no copying happens.
(define (copy-pref-value p value)
(let/ec k
(define pref-state (find-layer p))
(define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
(define un/marshaller (hash-ref marshall-unmarshall p (λ () (k value))))
(define default (hash-ref (preferences:layer-defaults pref-state) p))
(define marsh (un/marshall-marshall un/marshaller))
(define unmarsh (un/marshall-unmarshall un/marshaller))
(define marshalled (marsh value))
(define copy (unmarsh marshalled))
(if ((default-checker default) copy)
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)))))
(let* ([un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))]
[default (hash-ref defaults p)]
[marsh (un/marshall-marshall un/marshaller)]
[unmarsh (un/marshall-unmarshall un/marshaller)]
[marshalled (marsh value)]
[copy (unmarsh marshalled)])
(if ((default-checker default) copy)
copy
value))))
(define-struct preferences:snapshot (x))
(define (preferences:get-prefs-snapshot)
(make-preferences:snapshot
(let loop ([prefs-state (preferences:current-layer)]
[sofar '()])
(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]))))
(hash-map defaults
(λ (k v) (cons k (copy-pref-value k (preferences:get k)))))))
(define (preferences:restore-prefs-snapshot snapshot)
(multi-set (map car (preferences:snapshot-x snapshot))
(map cdr (preferences:snapshot-x snapshot)))
(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
(proc-doc/names
@ -467,10 +414,6 @@ the state transitions / contracts are:
unmarshalling functions by calling
@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
@racket[exn:unknown-preference?]
if the preference default has not been set via
@ -562,19 +505,13 @@ the state transitions / contracts are:
preferences:register-save-callback
(-> (-> boolean? any) symbol?)
(callback)
@{Registers @racket[callback] to run twice for each call
to @racket[preferences:set]---once before the preferences
file is written, with @racket[#t], and once after it is
written, with @racket[#f]. Registration returns a key for
use with @racket[preferences:unregister-save-callback].
Caveats: @itemize{
@item{The callback occurs on whichever
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.}}})
@{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once
before the preferences file is written, with @racket[#t], and once after it is written, with
@racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback].
Caveats:
@itemize{@item{The callback occurs on whichever 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
preferences:unregister-save-callback
@ -602,7 +539,7 @@ the state transitions / contracts are:
(parameter-doc
preferences:low-level-put-preferences
(parameter/c (-> (listof symbol?) (listof any/c) any))
(parameter/c ((listof symbol?) (listof any/c) . -> . any))
put-preferences
@{This parameter's value is called to save preference the preferences file.
Its interface should be just like mzlib's @racket[put-preferences].
@ -649,64 +586,4 @@ the state transitions / contracts are:
copied by passing it through the marshalling and unmarshalling process.
Other values are not copied, but references to them are instead saved.
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"]})
)
See also @racket[preferences:restore-prefs-snapshot].}))

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

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

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

@ -157,43 +157,21 @@
hp)]
[callback
(λ (color-button evt)
(define pref (get-from-pref-sym))
(define orig-add (send pref get-foreground-add))
(define orig-mult (send pref get-foreground-mult))
(define (avg x y z) (/ (+ x y z) 3))
(define (pin-between lo x hi) (min (max lo x) hi))
(define orig-α
(- 1 (pin-between 0
(avg (send orig-mult get-r)
(send orig-mult get-g)
(send orig-mult get-b))
1)))
(define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255))
(define color
(make-object color%
(to-byte (- 255 (/ (- 255 (send orig-add get-r)) orig-α)))
(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-α))))))])))
(let* ([add (send (get-from-pref-sym) get-foreground-add)]
[color (make-object color%
(send add get-r)
(send add get-g)
(send add get-b))]
[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)
(send delta set-delta-foreground users-choice))))))])))
(define background-color-button
(and (>= (get-display-depth) 8)
background?

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

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

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

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

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

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

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

@ -738,25 +738,6 @@
(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
(mixin (basic<%>) (info<%>)
[define rest-panel 'uninitialized-root]
@ -871,35 +852,55 @@
(new grow-box-spacer-pane% [parent outer-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)
(set! pref-save-canvas (new pref-save-canvas% [parent (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
(let* ([panel (new horizontal-panel%
[parent (get-info-panel)]
[stretchable-width #f]
[stretchable-height #f])])
(set! this-frames-memory-canvas
(new memory-position-canvas%
[parent panel]
[button-up
(λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'framework/private/follow-log #f)]
[else
(collect-garbage)
(update-memory-text)]))]))
(set! memory-canvases (cons this-frames-memory-canvas memory-canvases))
(maybe-create-memory-use-timer)
[stretchable-height #f])]
[ec (new position-canvas%
[parent panel]
[button-up
(λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'framework/private/follow-log #f)]
[else
(collect-garbage)
(update-memory-text)]))]
[init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases))
(update-memory-text)
(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))
(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)))))
(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-mixin
(mixin (info<%>) (text-info<%>)
@ -1539,8 +1509,7 @@
(string-constant no)
(string-constant are-you-sure-revert-title)
#f
this
#:dialog-mixin focus-table-mixin))
this))
(revert))))
#t))
@ -2401,11 +2370,7 @@
(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-on-demand item)
(send item enable (and find-edit
(not (string=? (send find-edit get-text) ""))
(not hidden?)
replace-visible?)))
(define/override (edit-menu:replace-all-on-demand item) (send item enable (not hidden?)))
(define/override (edit-menu:create-replace-all?) #t)
(define/override make-root-area-container
@ -2573,14 +2538,9 @@
(hash-set! ht found-txt #t)
(send found-txt begin-edit-sequence))
(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)
(define revision-after (send found-txt get-revision-number))
(unless (= revision-before revision-after)
(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))))))))
(copy-over replace-edit 0 (send replace-edit last-position) found-txt start)
(loop found-txt (+ start (send replace-edit last-position)))))))
(hash-for-each ht (λ (txt _) (send txt end-edit-sequence)))))))
(define/private (pop-all-the-way-out txt)
@ -2787,6 +2747,8 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new)))
(define memory-canvases '())
(define bday-click-canvas%
(class canvas%
(define/override (on-event evt)

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

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

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

@ -25,12 +25,6 @@
(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:color-scheme 'classic symbol?)
@ -559,12 +553,21 @@
(preferences:set-default 'framework:coloring-active #t boolean?)
(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
'framework:default-text-color
(λ (v)
(editor:set-default-font-color v)))
(editor:set-default-font-color
v
(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: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")

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

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

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

@ -512,11 +512,6 @@ the state transitions / contracts are:
(string-constant maximum-char-width-guide-pref-check-box)
(λ (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))))])
(add-editor-checkbox-panel)))

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

@ -1350,11 +1350,19 @@
(send text end-edit-sequence))
(define tabify-pref (preferences:get 'framework:tabify))
(define tabify-pref-callback (lambda (k v) (set! tabify-pref v)))
(preferences:add-callback
'framework:tabify
tabify-pref-callback
#t)
(lambda (k v) (set! tabify-pref v)))
(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)
;; don't call the surrogate's super, since it sets the default extension
@ -1364,41 +1372,12 @@
(sup directory default-name))]
[else (sup directory default-name)]))
(define/override (set-get-token get-token-)
(super set-get-token (wrap-get-token get-token- (λ () tabify-pref))))
(super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref)))
(super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
(token-sym->style short-sym->style-name)
(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)
;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-head-sexp-type-from-prefs text pref)

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

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

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

@ -530,7 +530,7 @@
delete find-snip
get-style-list change-style
position-line line-start-position
get-filename get-end-position)
get-filename)
(define/public (get-fixed-style)
(send (get-style-list) find-named-style "Standard"))
@ -586,79 +586,28 @@
(set! edition (+ edition 1))
(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
#:try-to-move? [try-to-move? #t])
(unless (and (<= 0 start) (<= 0 end) (<= 0 dest-position))
(error 'move/copy-to-edit
"expected start, end, and dest-pos to be non-negative"))
(when (> start end)
(error 'move/copy-to-edit
"expected start position smaller than end position"))
(cond
[try-to-move? (move-to dest-edit start end dest-position)]
[else (copy-to dest-edit start end dest-position)]))
(split-snip start)
(split-snip end)
(let loop ([snip (find-snip end 'before)])
(cond
[(or (not snip) (< (get-snip-position snip) start))
(void)]
[else
(let ([prev (send snip previous)]
[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)
(define (initial-autowrap-bitmap) (icon:get-autowrap-bitmap))
@ -2305,8 +2254,7 @@
(gui-utils:get-choice
(string-constant save-as-plain-text)
(string-constant yes)
(string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(string-constant no))))
(set-file-format 'text)]
[(and (not all-strings?)
(eq? format 'same)
@ -2315,8 +2263,7 @@
(gui-utils:get-choice
(string-constant save-in-drs-format)
(string-constant yes)
(string-constant no)
#:dialog-mixin frame:focus-table-mixin)))
(string-constant no))))
(set-file-format 'standard)]
[else (void)]))
(inner (void) on-save-file name format))
@ -3056,12 +3003,7 @@
(cond
[(= start end) (flush-proc)]
[else
(define pair (cons (if (and (= start 0)
(= end (bytes-length to-write))
(immutable? to-write))
to-write
(subbytes to-write start end))
style))
(define pair (cons (subbytes to-write start end) style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-channel (make-channel))
@ -3373,7 +3315,7 @@
[(potential-commits new-commit-response-evts)
(separate
committers
(service-committer (at-queue-size data) peeker-evt))])
(service-committer data peeker-evt))])
(when (and on-peek
(not (null? not-ready-peekers)))
(parameterize ([current-eventspace eventspace])
@ -3396,7 +3338,7 @@
(handle-evt
read-chan
(λ (ent)
(at-enqueue! ent data)
(set! data (at-enqueue ent data))
(unless position
(set! position (cdr ent)))
(loop)))
@ -3496,22 +3438,23 @@
;; service-committer : queue evt -> committer -> (union #f evt)
;; if the committer can be dumped, return an evt that
;; 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
[(struct committer
(kr commit-peeker-evt
done-evt resp-chan resp-nack))
(cond
[(not (eq? peeker-evt commit-peeker-evt))
(choice-evt
resp-nack
(channel-put-evt resp-chan #f))]
[(< size kr)
(choice-evt
resp-nack
(channel-put-evt resp-chan 'commit-failure))]
[else ;; commit succeeds
#f])]))
(let ([size (at-queue-size data)])
(cond
[(not (eq? peeker-evt commit-peeker-evt))
(choice-evt
resp-nack
(channel-put-evt resp-chan #f))]
[(< size kr)
(choice-evt
resp-nack
(channel-put-evt resp-chan 'commit-failure))]
[else ;; commit succeeds
#f]))]))
;; service-waiter : peeker -> (union #f evt)
;; 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?)
(define/public (set-line-numbers-color color)
(define new-line-numbers-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))
(set! line-numbers-color color))
(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)))
(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
(define/private (setup-dc dc)
@ -4988,9 +4925,6 @@ designates the character that triggers autocompletion
(cons e (at-queue-front q))
(at-queue-back q)
(+ (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)
(at-flip-around q)
(let ([back (at-queue-back q)])

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

@ -1024,7 +1024,7 @@
@method[canvas<%> on-event] method.
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.
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"
"scheme-lib"
"scribble-lib"
["string-constants-lib" #:version "1.14"]
["string-constants-lib" #:version "1.9"]
"option-contract-lib"
"2d-lib"
"compatibility-lib"
@ -30,4 +30,4 @@
(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)))
(parameterize ([current-launcher-variant v])
(create-embedding-executable
(prep-dir (mred-program-launcher-path "MrEd"
#:user? user?
#:tethered? tethered?))
(prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
#:cmdline (append
(if tethered? (if user? (addon-flags) (config-flags)) null)
'("-I" "scheme/gui/init"))
@ -45,10 +43,7 @@
(make-gracket-launcher
#:tether-mode tether-mode
'("-I" "scheme/gui/init" "-z")
(prep-dir (mred-program-launcher-path "mred-text"
#:user? user?
#:tethered? tethered?
#:console? #t))
(prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
`([relative? . ,(not (or user? tethered?))]
[subsystem . console]
[single-instance? . #f]))))))
@ -59,9 +54,7 @@
(make-gracket-launcher
#:tether-mode tether-mode
null
(prep-dir (mred-program-launcher-path "MrEd"
#:user? user?
#:tethered? tethered?))
(prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
`([exe-name . "GRacket"]
[relative? . ,(not (or user? tethered?))]
[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 kCommandUnicode #x2318) ;/* Unicode PLACE OF INTEREST SIGN*/
(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;
; 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 kDiamondUnicode #x25C6) ;/* Unicode BLACK DIAMOND*/
(define-unicode-key kBulletUnicode #x2022) ;/* Unicode BULLET*/

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

@ -34,6 +34,7 @@
yield)
(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray)
(import-protocol NSApplicationDelegate)
;; Extreme hackery to hide original arguments from
;; NSApplication, because NSApplication wants to turn
@ -51,7 +52,7 @@
(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])
(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)))))
(define/public (update-message [val (get-value)])
(tellv message-cocoa setStringValue: #:type _NSString (format "~a" val))
(tellv message-cocoa sizeToFit))
(tellv message-cocoa setStringValue: #:type _NSString (format "~a" val)))
(inherit get-cocoa-window)
(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)]
[h (box 0)])
(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))
(let ([cr (super get-cr)])
(set! retained-cr cr)

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

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

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

@ -36,7 +36,7 @@
(cons 'blank void)
(cons 'hand GDK_HAND2))))
(define _GdkCursor (_cpointer/null 'GdkCursor))
(define _GdkCursor (_cpointer 'GdkCursor))
(define-gdk gdk_cursor_new (_fun _int -> _GdkCursor))
(define-gdk gdk_display_get_default (_fun -> _GdkDisplay))
(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
"utils.rkt"
"types.rkt"
"queue.rkt"
"window.rkt"
"frame.rkt"
"x11.rkt"
@ -196,11 +195,9 @@
(define/override (make-backing-bitmap w h)
(cond
[(and (not is-transparentish?)
(not wayland?)
(eq? 'unix (system-type)))
(make-object x11-bitmap% w h (send canvas get-client-gtk))]
[(and (not is-transparentish?)
(not wayland?)
(eq? 'windows (system-type)))
(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
[else

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

@ -1,6 +1,5 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
racket/class
racket/promise
racket/runtime-path
@ -17,7 +16,6 @@
"cursor.rkt"
"pixbuf.rkt"
"resolution.rkt"
"queue.rkt"
"../common/queue.rkt")
(provide
@ -90,10 +88,6 @@
[max_aspect _double]
[win_gravity _int]))
(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_put (_fun _GtkWidget _GtkWidget _int _int -> _void))
@ -113,15 +107,11 @@
(lambda (gtk a)
(let ([wx (gtk->wx gtk)])
(when wx
(define-values (w h) (if gtk3?
(gtk_window_get_size gtk)
(values (GdkEventConfigure-width a)
(GdkEventConfigure-height a))))
(send wx remember-size
(->normal (GdkEventConfigure-x a))
(->normal (GdkEventConfigure-y a))
(->normal w)
(->normal h))))
(->normal (GdkEventConfigure-width a))
(->normal (GdkEventConfigure-height a)))))
#f))
(define-cstruct _GdkEventWindowState ([type _int]
@ -247,9 +237,6 @@
(define/override (set-child-size child-gtk x y w h)
(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)))
(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 (to-max v) (if (= v -1) #x3FFFFF (->screen v)))
(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
(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
(->screen inc-x) (->screen inc-y)
0.0 0.0

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

@ -6,7 +6,6 @@
"utils.rkt"
"types.rkt"
"window.rkt"
"queue.rkt"
"pixbuf.rkt"
"x11.rkt")
@ -20,7 +19,7 @@
bitmap->gc-bitmap))
;; Gtk2, only:
(define-cstruct _GdkWindowAttr2
(define-cstruct _GdkWindowAttr
([title _string]
[event_mask _int]
[x _int]
@ -37,29 +36,6 @@
[override_redirect _gboolean]
[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 GDK_WA_TITLE (1 . << . 1))
@ -76,19 +52,12 @@
(define GDK_WINDOW_CHILD 2)
(define-gdk gdk_window_new (_fun _GdkWindow
(if gtk3?
_GdkWindowAttr3-pointer
_GdkWindowAttr2-pointer)
_uint -> _GdkWindow))
(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint -> _GdkWindow))
(define-gdk gdk_window_show-p _fpointer
#:c-id gdk_window_show)
(define-gdk gdk_window_show _fpointer)
(define-gdk gdk_window_hide _fpointer)
(define-gdk gdk_display_flush _fpointer)
(define-gdk gdk_window_show (_fun _GdkWindow -> _void))
;; Gtk2
(define-gdk gdk_draw_pixbuf _fpointer
#:make-fail make-not-available)
@ -100,11 +69,9 @@
(define-x11 XMapRaised _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)
(cond
[use-x11?
[gtk3?
; Generate an X11 Pixmap
(define gwin (widget-window client-gtk))
(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 cwin (widget-window client-gtk))
(cond
[use-x11?
[gtk3?
;; 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 s (gtk_widget_get_scale_factor client-gtk))
@ -165,61 +132,51 @@
(define (free-gc-window win)
(cond
[use-x11? (XDestroyWindow (car win) (cdr win))]
[gtk3? (XDestroyWindow (car win) (cdr win))]
[else (g_object_unref win)]))
(define (make-draw win gc-bitmap w h)
(cond
[use-x11? (vector
(vector 'ptr_ptr_ptr->void
XSetWindowBackgroundPixmap
(car win)
(cdr win)
gc-bitmap))]
[gtk3? (vector)]
[else (vector
(vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
gdk_draw_pixbuf
win #f gc-bitmap
0 0 0 0 w h
0 0 0))]))
[gtk3? (vector 'ptr_ptr_ptr->void
XSetWindowBackgroundPixmap
(car win)
(cdr win)
gc-bitmap)]
[else (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
gdk_draw_pixbuf
win #f gc-bitmap
0 0 0 0 w h
0 0 0)]))
(define (make-flush)
(vector
(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))
(vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))
(define (make-gc-show-desc win gc-bitmap w h)
(cond
[use-x11? (vector*
(make-draw win gc-bitmap w h)
(vector
(vector 'ptr_ptr_ptr->void
XMapRaised
(car win)
(cdr win)
#f))
(make-flush))]
[else (vector*
(vector
(vector 'ptr_ptr_ptr->void gdk_window_show-p win #f #f))
[gtk3? (vector
(make-draw win gc-bitmap w h)
(vector 'ptr_ptr_ptr->void
XMapRaised
(car win)
(cdr win)
#f)
(make-flush))]
[else (vector
(vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
(make-draw win gc-bitmap w h)
(make-flush))]))
(define (make-gc-hide-desc win gc-bitmap w h)
(vector*
(vector
;; draw the ``off'' bitmap so we can flush immediately
(make-draw win gc-bitmap w h)
(make-flush)
(vector
;; hide the window; it may take a while for the underlying canvas
;; to refresh:
(if use-x11?
(vector 'ptr_ptr_ptr->void
XUnmapWindow
(car win)
(cast (cdr win) _Window _pointer)
#f)
(vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f)))))
;; hide the window; it may take a while for the underlying canvas
;; to refresh:
(if gtk3?
(vector 'ptr_ptr_ptr->void
XUnmapWindow
(car win)
(cast (cdr win) _Window _pointer)
#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
(let* ([target-size
(cond
[(and gtk3?
((gtk_get_minor_version) . < . 22))
;; Prior to version 3.22, GTK+3 ignores the
;; "size-in-pixels" part of a font spec, so we have to
;; 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.
[gtk3?
;; Gtk3 ignores the "size-in-pixels" part of a
;; font spec, so we have to adjust the text size
;; to compensate.
(* (send font get-size)
(/ 72.0
(pango_cairo_font_map_get_resolution

12
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_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))
@ -138,16 +137,7 @@
(super-new)
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move (get-container-gtk) child-gtk (->screen x) (->screen y))
(define re-hide?
(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)))))
(gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))))
(define panel%
(class (panel-container-mixin (panel-mixin window%))

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

@ -116,17 +116,8 @@
(g_free f))))))
default))
(define (get-control-font-size)
(define s (get-control-font (lambda (m) (string->number (cadr m)))
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]))
(get-control-font (lambda (m) (string->number (cadr m)))
10))
(define (get-control-font-face)
(get-control-font (lambda (m) (car m))
"Sans"))
@ -156,10 +147,9 @@
(define/top (make-screen-bitmap [exact-positive-integer? w]
[exact-positive-integer? h])
(if (and (eq? 'unix (system-type))
(not wayland?))
(if (eq? 'unix (system-type))
(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]
[exact-positive-integer? h]

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

@ -16,7 +16,6 @@
try-to-sync-refresh
set-widget-hook!
x11-display)
wayland?
;; from common/queue:
current-eventspace
queue-event
@ -91,19 +90,6 @@
(gdk_set_program_class (cast v _pointer _string))))
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

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

@ -51,8 +51,6 @@
gdk_screen_get_default
gtk_get_minor_version
;; for declaring derived structures:
_GtkObject
@ -202,9 +200,6 @@
(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)
(string-join
(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-parent
avoid-preferred-size-warning
the-accelerator-group
gtk_window_add_accel_group
gtk_menu_set_accel_group
@ -104,14 +102,6 @@
(define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int)
#: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_ungrab (_fun _int -> _void))
@ -259,9 +249,6 @@
(lambda (gtk event)
(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?)
(let ([wx (gtk->wx gtk)])
(and
@ -292,22 +279,12 @@
[(= dir GDK_SCROLL_RIGHT) 'wheel-right]
[(= dir GDK_SCROLL_SMOOTH)
(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
[(>= scroll-accum-y 1)
(set! scroll-accum-y (sub1 scroll-accum-y))
'wheel-down]
[(<= scroll-accum-y -1)
(set! scroll-accum-y (add1 scroll-accum-y))
'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])]
[(positive? dy) 'wheel-down]
[(negative? dy) 'wheel-up]
[(positive? dx) 'wheel-right]
[(negative? dx) 'wheel-left]
[else #f])]
[else #f]))]
[(and (string? im-str)
(= 1 (string-length im-str)))
@ -637,7 +614,7 @@
(set! client-delta-h (->normal
(- (GtkRequisition-height req)
(GtkRequisition-height creq)))))
(when gtk3? (gtk_widget_hide gtk))))
(when gtk3? (gtk_widget_show gtk))))
(define/public (set-auto-size [dw 0] [dh 0])
(let ([req (make-GtkRequisition 0 0)])
@ -656,7 +633,7 @@
(define/public (direct-show on?)
;; atomic mode
(if on?
(gtk_widget_show gtk)
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t))
(register-child-in-parent on?)
@ -926,7 +903,7 @@
;; windows; that means we have to be extra careful that
;; the underlying window doesn't change while a freeze is
;; in effect; the `reset-child-freezes` helps with that.
(unless (or (and transparentish? gtk3?) wayland?)
(unless (and transparentish? gtk3?)
(gdk_window_ensure_native win))
(begin
(gdk_window_freeze_updates win)

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

@ -407,7 +407,7 @@
[center (lambda (dir)
(when pending-redraws? (force-redraw))
(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
;; input: new-width/new-height: new size of frame

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

@ -1,6 +1,4 @@
#lang racket/base
(module+ test (require rackunit))
#|
needed to really make this work:
@ -13,20 +11,13 @@ needed to really make this work:
racket/class
racket/gui/base
racket/match
racket/contract
(prefix-in : racket/base)
(prefix-in - racket/base)
"include-bitmap.rkt")
(define orig-output-port (current-output-port))
(define (oprintf . args) (apply fprintf orig-output-port args))
(provide
(contract-out
[render-syntax/snip
(-> syntax? (is-a?/c snip%))]
[render-syntax/window
(-> syntax? void?)])
snip-class)
(provide render-syntax/snip render-syntax/window snip-class)
;; this is doing the same thing as the class in
;; the framework by the same name, but we don't
@ -56,7 +47,7 @@ needed to really make this work:
(class snip-class%
(define/override (read stream)
(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)))
(define snip-class (new syntax-snipclass%))
@ -79,6 +70,8 @@ needed to really make this work:
(define/override (write stream)
(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 output-text (new text:hide-caret/selection%))
@ -92,14 +85,67 @@ needed to really make this work:
0
(send text last-position)))
(define path '())
(define next-push 0)
(define/private (push!)
(set! path (cons next-push path))
(set! next-push 0))
(define/private (pop!)
(set! next-push (+ (car path) 1))
(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)
;; range-start-ht : hash-table[obj -o> number]
@ -398,91 +444,6 @@ needed to really make this work:
(inherit set-snipclass)
(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 green-style-delta (make-object style-delta%))
(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
'("-z")
(prep-dir
(mred-program-launcher-path "gracket-text"
#:user? user?
#:tethered? tethered?
#:console? #t))
(mred-program-launcher-path "gracket-text" #:user? user? #:tethered? tethered?))
`([subsystem . console]
[single-instance? . #f]
[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"))]))

1074
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
| 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
| 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.
- canvases: canvas.rkt -- now runs directly via raco test.
- texts: text.rkt -- now runs directly via raco test.
- texts: |# text.rkt #|
- pasteboards: |# pasteboard.rkt #|
- keybindings: keys.rkt -- now runs directly via raco test.
- keybindings: |# keys.rkt #|
| This tests the misc (non-scheme) keybindings
@ -61,12 +61,12 @@ signal failures when there aren't any.
| 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.
| 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

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

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

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

@ -1,13 +1,13 @@
#lang racket/base
(require "private/util.rkt"
(require "private/here-util.rkt"
"private/gui.rkt"
rackunit
racket/class
racket/gui/base
framework)
(define (test-creation name create [verify void])
(define (test-creation name create)
(check-true
(let ()
(parameterize ([current-eventspace (make-eventspace)])
@ -20,7 +20,6 @@
(channel-put c (send f get-label))))
(define frame-label (channel-get c))
(wait-for-frame frame-label)
(verify f)
(queue-callback (λ () (send f close)))
#t))
(format "create ~a" name)))
@ -87,72 +86,6 @@
'pasteboard%-creation
(λ () (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-file-contents "test")
(check-equal?
@ -203,125 +136,19 @@
(test-open "frame:searchable open" frame:searchable%)
(test-open "frame:text open" frame:text%))
(define (replace-all-tests)
(parameterize ([current-eventspace (make-eventspace)])
(define plain-f
(let ()
(define c (make-channel))
(queue-callback
(λ ()
(define f (new frame:searchable% [width 400] [height 400]))
(send f show #t)
(channel-put c f)))
(channel-get c)))
(define (try f content search-string replace-string)
(define c (make-channel))
(queue-callback
(λ ()
(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)))
(let ([pref-ht (make-hash)])
(parameterize ([test:use-focus-table #t]
[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)))])
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
(send dummy show #t)
(creation-tests)
(open-tests)
(send dummy show #f)))

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

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

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

@ -1,195 +1,236 @@
#lang racket/gui
(require framework rackunit "private/util.rkt")
#lang racket/base
(check-equal?
(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")))
(require "test-suite-utils.rkt")
(check-equal?
(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))
'((c:k "def")))
(module test racket/base)
(check-equal?
(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))
'((c:k "abc-k2")))
(test
'keymap:aug-keymap%/get-table
(lambda (x)
(equal? '((c:k "abc")) x))
(lambda ()
(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)))))
(check-equal?
(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))
'((c:k "abc-k")))
(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)))))
(check-equal?
(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))
'((|esc;p| "abc-k2")))
(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)))))
(check-equal?
(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "shift-em" void)
(send k add-function "shift-ah" void)
(send k map-function "s:m" "shift-em")
(send k map-function "s:a" "shift-ah")
(sort (hash-map (send k get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x))))
'((s:a "shift-ah") (s:m "shift-em")))
(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)))))
(check-equal?
(let ()
(define k0 (new keymap:aug-keymap%))
(define k1 (new keymap:aug-keymap%))
(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))))
'((|c:x;r| "swap if branches")))
(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? (keymap:canonicalize-keybinding-string "c:a") "c:a")
(check-equal? (keymap:canonicalize-keybinding-string "d:a") "d:a")
(check-equal? (keymap:canonicalize-keybinding-string "m:a") "m:a")
(check-equal? (keymap:canonicalize-keybinding-string "a:a") "a:a")
(check-equal? (keymap:canonicalize-keybinding-string "s:a") "s:a")
(check-equal? (keymap:canonicalize-keybinding-string "c:a") "c:a")
(check-equal? (keymap:canonicalize-keybinding-string "s:m:d:c:a:a") "a:c:d:m:s:a")
(check-equal? (keymap:canonicalize-keybinding-string "~s:~m:~d:~c:~a:a") "~a:~c:~d:~m:~s:a")
(check-equal? (keymap:canonicalize-keybinding-string ":a") "~a:~c:~d:~m:~s:a")
(check-equal? (keymap:canonicalize-keybinding-string ":d:a") "~a:~c:d:~m:~s:a")
(check-equal? (keymap:canonicalize-keybinding-string "esc;s:a") "esc;s:a")
(check-equal? (keymap:canonicalize-keybinding-string "s:a;esc") "s:a;esc")
(check-equal? (keymap:canonicalize-keybinding-string "ESC;p") "esc;p")
(check-equal? (keymap:canonicalize-keybinding-string "?:a:v") "?:a:v")
(check-equal? (keymap:canonicalize-keybinding-string "a:?:v") "?:a:v")
(check-equal? (keymap:canonicalize-keybinding-string "l:v") "l:v")
(check-equal? (keymap:canonicalize-keybinding-string "c:l:v") "c:l:v")
(test
'keymap:aug-keymap%/all-but-last-bug
(lambda (x)
(equal? x '((s:a "shift-ah") (s:m "shift-em"))))
(lambda ()
(queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "shift-em" void)
(send k add-function "shift-ah" void)
(send k map-function "s:m" "shift-em")
(send k map-function "s:a" "shift-ah")
(sort (hash-map (send k get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
;; 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)
(test
'keymap:aug-keymap%/longer-name
(lambda (x)
(equal? x '((|c:x;r| "swap if branches"))))
(lambda ()
(queue-sexp-to-mred
'(let ()
(define k0 (new keymap:aug-keymap%))
(define k1 (new keymap:aug-keymap%))
(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)))))))
;; 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))
(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)))))
;; 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)
(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")
(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))))
;; 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)
(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))))
;; 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))
;; 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))))))
;; 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-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 (build-buff-spec string start end #:overwrite? [overwrite? #f])
(make-buff-spec string start end overwrite?))
(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 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))))
;; 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/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)
(build-buff-spec "'(abc (def))" 12 12)
(list '(right alt))
@ -201,264 +242,243 @@
(list '(left alt))
(list '(left alt)))
|#
(build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(f cond " 8 #\()
(build-open-bracket-spec "(f let (" 8 #\()
(build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(let (" 5 #\()
(build-open-bracket-spec "(provide/contract " 18 #\[)
(build-open-bracket-spec "(kond " 5 #\()
(build-open-bracket-spec "(cond " 5 #\[)
(build-open-bracket-spec "(case-lambda " 13 #\[)
(build-open-bracket-spec "(let ([]" 8 #\[)
(build-open-bracket-spec "(let ({}" 8 #\{)
(build-open-bracket-spec "()" 2 #\()
(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 "" 0 #\()
(build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(new x% " 8 #\[)
(build-open-bracket-spec "#\\" 2 #\[)
(build-open-bracket-spec "#\\a" 2 #\[)
(build-open-bracket-spec "(let ([let (" 12 #\()
(build-open-bracket-spec "ab" 1 #\()
(build-open-bracket-spec "|ab|" 2 #\[)
(build-open-bracket-spec "(let loop " 10 #\()
(build-open-bracket-spec "(let loop (" 11 #\[)
(build-open-bracket-spec "(case x " 8 #\[)
(build-open-bracket-spec "(case x [" 9 #\()
(build-open-bracket-spec "(let ([])(" 10 #\()
(build-open-bracket-spec "(local " 7 #\[)
(build-open-bracket-spec "(local []" 9 #\()
;; test to show that multi-keystrokes works:
(make-key-spec/allplatforms
(build-buff-spec "" 0 0)
(build-buff-spec "zx" 2 2)
(list '((#\z) (#\x))))
;; remove-enclosing-parens :
(make-key-spec/allplatforms
(build-buff-spec "(abc def)" 1 1)
(build-buff-spec "abc" 0 0)
(list '((#\c control) (#\o control))))
;; (is this the desired behavior?):
(make-key-spec/allplatforms
(build-buff-spec "(abc def)" 2 3)
(build-buff-spec "bc" 0 0)
(list '((#\c control) (#\o control))))
;; insert-()-pair :
(make-key-spec
(build-buff-spec "abc" 0 0)
(build-buff-spec "()abc" 1 1)
(list '((escape) (#\()))
(list '((#\( meta)))
(list '((escape) (#\())))
(make-key-spec
(build-buff-spec "abc" 0 2)
(build-buff-spec "(ab)c" 1 1)
(list '((escape) (#\()))
(list '((#\( meta)))
(list '((escape) (#\())))
;; toggle-square-round-parens :
; () -> []
(make-key-spec/allplatforms
(build-buff-spec "(a)" 0 0)
(build-buff-spec "[a]" 0 0)
(list '((#\c control) (#\[ control))))
; [] -> ()
(make-key-spec/allplatforms
(build-buff-spec "[a]" 0 0)
(build-buff-spec "(a)" 0 0)
(list '((#\c control) (#\[ control))))
; enclosed sexps
(make-key-spec/allplatforms
(build-buff-spec "[a (def )b]" 0 0)
(build-buff-spec "(a (def )b)" 0 0)
(list '((#\c control) (#\[ control))))
; extra preceding whitespace
(make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 0 0)
(build-buff-spec " \n (a (def )b)" 0 0)
(list '((#\c control) (#\[ control))))
; cursor not at beginning of buffer
(make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 1 1)
(build-buff-spec " \n (a (def )b)" 1 1)
(list '((#\c control) (#\[ control))))
; intervening non-paren sexp
(make-key-spec/allplatforms
(build-buff-spec " \nf [a (def )b]" 1 1)
(build-buff-spec " \nf [a (def )b]" 1 1)
(list '((#\c control) (#\[ control))))
;; at end of buffer (hence sexp-forward returns #f):
(make-key-spec/allplatforms
(build-buff-spec "[a]" 3 3)
(build-buff-spec "[a]" 3 3)
(list '((#\c control) (#\[ control))))
(build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(f cond " 8 #\()
(build-open-bracket-spec "(f let (" 8 #\()
(build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(let (" 5 #\()
(build-open-bracket-spec "(provide/contract " 18 #\[)
(build-open-bracket-spec "(kond " 5 #\()
(build-open-bracket-spec "(cond " 5 #\[)
(build-open-bracket-spec "(case-lambda " 13 #\[)
(build-open-bracket-spec "(let ([]" 8 #\[)
(build-open-bracket-spec "(let ({}" 8 #\{)
(build-open-bracket-spec "()" 2 #\()
(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 "" 0 #\()
(build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(new x% " 8 #\[)
(build-open-bracket-spec "#\\" 2 #\[)
(build-open-bracket-spec "#\\a" 2 #\[)
(build-open-bracket-spec "(let ([let (" 12 #\()
(build-open-bracket-spec "ab" 1 #\()
(build-open-bracket-spec "|ab|" 2 #\[)
(build-open-bracket-spec "(let loop " 10 #\()
(build-open-bracket-spec "(let loop (" 11 #\[)
(build-open-bracket-spec "(case x " 8 #\[)
(build-open-bracket-spec "(case x [" 9 #\()
(build-open-bracket-spec "(let ([])(" 10 #\()
(build-open-bracket-spec "(local " 7 #\[)
(build-open-bracket-spec "(local []" 9 #\()
;; test to show that multi-keystrokes works:
(make-key-spec/allplatforms
(build-buff-spec "" 0 0)
(build-buff-spec "zx" 2 2)
(list '((#\z) (#\x))))
;; remove-enclosing-parens :
(make-key-spec/allplatforms
(build-buff-spec "(abc def)" 1 1)
(build-buff-spec "abc" 0 0)
(list '((#\c control) (#\o control))))
;; (is this the desired behavior?):
(make-key-spec/allplatforms
(build-buff-spec "(abc def)" 2 3)
(build-buff-spec "bc" 0 0)
(list '((#\c control) (#\o control))))
;; insert-()-pair :
(make-key-spec
(build-buff-spec "abc" 0 0)
(build-buff-spec "()abc" 1 1)
(list '((escape) (#\()))
(list '((#\( meta)))
(list '((escape) (#\())))
(make-key-spec
(build-buff-spec "abc" 0 2)
(build-buff-spec "(ab)c" 1 1)
(list '((escape) (#\()))
(list '((#\( meta)))
(list '((escape) (#\())))
;; toggle-square-round-parens :
; () -> []
(make-key-spec/allplatforms
(build-buff-spec "(a)" 0 0)
(build-buff-spec "[a]" 0 0)
(list '((#\c control) (#\[ control))))
; [] -> ()
(make-key-spec/allplatforms
(build-buff-spec "[a]" 0 0)
(build-buff-spec "(a)" 0 0)
(list '((#\c control) (#\[ control))))
; enclosed sexps
(make-key-spec/allplatforms
(build-buff-spec "[a (def )b]" 0 0)
(build-buff-spec "(a (def )b)" 0 0)
(list '((#\c control) (#\[ control))))
; extra preceding whitespace
(make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 0 0)
(build-buff-spec " \n (a (def )b)" 0 0)
(list '((#\c control) (#\[ control))))
; cursor not at beginning of buffer
(make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 1 1)
(build-buff-spec " \n (a (def )b)" 1 1)
(list '((#\c control) (#\[ control))))
; intervening non-paren sexp
(make-key-spec/allplatforms
(build-buff-spec " \nf [a (def )b]" 1 1)
(build-buff-spec " \nf [a (def )b]" 1 1)
(list '((#\c control) (#\[ control))))
;; at end of buffer (hence sexp-forward returns #f):
(make-key-spec/allplatforms
(build-buff-spec "[a]" 3 3)
(build-buff-spec "[a]" 3 3)
(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 "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 '((#\())))
(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 '((#\[))))
;; 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"))))
(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 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))
(queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
(wait-for-frame "dummy to trick frame group")
(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)))
;; 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)))
(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))))
(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)))
(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 old-paren-adjusting-prefs
(queue-sexp-to-mred `(list (preferences:get 'framework:fixup-open-parens)
(preferences:get 'framework:automatic-parens))))
(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)
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f))
(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)
(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))))))
(queue-sexp-to-mred
`(begin (preferences:set 'framework:fixup-open-parens ,(list-ref old-paren-adjusting-prefs 0))
(preferences:set 'framework:automatic-parens ,(list-ref old-paren-adjusting-prefs 1))))

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

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

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

@ -1,152 +1,141 @@
#lang racket/base
(require framework/preferences
racket/format
rackunit
racket/contract)
(require "test-suite-utils.rkt")
;(define ((check-equal? x) y) (equal? x y))
(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)
(module test racket/base)
(define the-prefs-table (make-hash))
(parameterize ([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))])
(define ((check-equal? x) y) (equal? x y))
(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)
(check-exn
exn:unknown-preference?
(λ ()
(preferences:get pref-sym)))
(shutdown-mred)
(check-equal?
(begin
(preferences:set-default pref-sym 'passed symbol?)
(preferences:get pref-sym))
'passed)
(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)))
(check-equal?
(begin (preferences:set pref-sym 'new-pref)
(preferences:get pref-sym))
'new-pref)
(test 'preference-marshalling
(check-equal? 'the-answer)
`(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)))
(begin0 ((preferences:get ',marshalling-pref-sym))
(preferences:set ',marshalling-pref-sym (lambda () 2)))))
(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))))
(check-true (preferences:default-set? pref-sym))
(check-false (preferences:default-set? 'unknown-preference))
(check-false (begin
(preferences:add-callback 'pref-with-only-callback-set void)
(preferences:default-set? 'pref-with-only-callback-set)))
(with-handlers ([eof-result? (lambda (x) (void))])
(send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
(exit:exit)
(check-equal?
(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)))
(begin0 ((preferences:get marshalling-pref-sym))
(preferences:set marshalling-pref-sym (lambda () 2))))
'the-answer)
;; 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)))))
(check-equal? ((preferences:get marshalling-pref-sym)) 2)
(test 'preference-get-after-restart
(check-equal? 'new-pref)
`(begin (preferences:set-default ',pref-sym 'passed symbol?)
(preferences:get ',pref-sym)))
;; make sure the preference actually got "written out"
(check-equal? (hash-ref the-prefs-table
(string->symbol (~a "plt:framework-pref:" pref-sym)))
'new-pref)
(test 'preference-no-set-default-stage1
(check-equal? 'stage1)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:set ',default-test-sym 'new-value)
'stage1))
(shutdown-mred)
(test 'preference-no-set-default-stage2
(check-equal? 'stage2)
`(begin 'stage2))
(shutdown-mred)
(test 'preference-no-set-default-stage3
(check-equal? 'new-value)
`(begin (preferences:set-default ',default-test-sym 'default symbol?)
(preferences:get ',default-test-sym)))
(let ()
(preferences:set-default 'unmarshalling-enumerate-test '() (listof exact-nonnegative-integer?))
(preferences:set-un/marshall 'unmarshalling-enumerate-test
(λ (lon) (~s lon))
(λ (s) (read (open-input-string s))))
(test 'preference-add-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define remove-it (preferences:add-callback ',default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
;; simulate a value having been saved from some prior run of the preferences library
(hash-set! the-prefs-table 'plt:framework-pref:unmarshalling-enumerate-test
(~s '(1 2 3 4 5)))
(test 'preference-add-weak-callback
(check-equal? 2)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback ',default-test-sym f #t))
(preferences:set ',default-test-sym 'xyz)
(remove-it)
(preferences:set ',default-test-sym 'pdq)
x)))
(check-equal? (preferences:get 'unmarshalling-enumerate-test) '(1 2 3 4 5)))
(test 'preference-add-weak-callback2
(check-equal? 3)
`(begin
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(unless (zero? (random 1)) (set! f 'not-a-proc)) ;; try to stop inlining
(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)))
(check-equal?
(let ([x 1])
(preferences:set-default default-test-sym 'default symbol?)
(define remove-it (preferences:add-callback default-test-sym (λ (a b) (set! x (+ x 1)))))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
2)
(test 'preference-weak-callback-is-weak
(check-equal? #t)
`(begin
(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)
(begin0
(let loop ([n 10])
(cond
[(not (weak-box-value wb)) #t]
[(zero? n) 'f-still-alive]
[else
(collect-garbage)
(loop (- n 1))]))
(remove-it)))))
(check-equal?
(let ([x 1])
(define remove-it (preferences:add-callback 'callback-before-delete (λ (a b) (set! x (+ x 1)))))
(preferences:set-default 'callback-before-delete 'default symbol?)
(preferences:set 'callback-before-delete 'xyz)
(remove-it)
(preferences:set 'callback-before-delete 'pdq)
x)
2)
(check-equal?
(let ([x 1])
(define f (λ (a b) (set! x (+ x 1))))
(define remove-it (preferences:add-callback default-test-sym f #t))
(preferences:set default-test-sym 'xyz)
(remove-it)
(preferences:set default-test-sym 'pdq)
x)
2)
(check-equal?
(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)))
(test 'dialog-appears
(check-equal? 'passed)
(lambda ()
(queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
(preferences:show-dialog)))
(wait-for-frame "Preferences")
(queue-sexp-to-mred '(begin (preferences:hide-dialog)
(let ([f (get-top-level-focus-window)])
(if f
(if (string=? "Preferences" (send f get-label))
'failed
'passed)
'passed))))))

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)
(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))
;----------------------------------------------------------------------