Fixed typo: get-port-location should be port-next-location

Closes #1.

gui-doc/mrlib/scribblings/image-core.scrbl

@@ -51,3 +51,11 @@ 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%].
+}

gui-doc/mrlib/scribblings/mrlib.scrbl

@@ -21,6 +21,7 @@
 @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"]
 

gui-doc/mrlib/scribblings/switchable-button.scrbl

@@ -8,7 +8,7 @@
 @defclass[switchable-button% canvas% ()]{
   
   A @racket[switchable-button%] control displays
-  and icon and a string label. It toggles between
+  an 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. 
   

gui-doc/mrlib/scribblings/syntax-browser.scrbl

@@ -0,0 +1,20 @@
+#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].
+}

gui-doc/scribblings/framework/color.scrbl

@@ -41,7 +41,8 @@
       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
@@ -53,7 +54,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[get-port-location]
+          number is relative to the third result of @racket[port-next-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.}]
@@ -63,7 +64,12 @@
     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 new mode; 
+    @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; 
     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];
@@ -83,12 +89,7 @@
     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[
@@ -187,11 +188,14 @@
     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].
   }
@@ -237,7 +241,8 @@
     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.
 
@@ -255,7 +260,8 @@
 
     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
@@ -266,7 +272,8 @@
 
     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)
@@ -369,7 +376,15 @@
 
 @defclass[color:text% (color:text-mixin text:keymap%) ()]{}
 
-@definterface[color:text-mode<%> ()]{}
+@definterface[color:text-mode<%> ()]{
+ @defmethod[(set-get-token [get-token procedure?]) void?]{
+  Sets the @racket[get-token] function used to color the contents
+  of the editor.
+
+  See @method[color:text<%> start-colorer]'s @racket[get-token] argument
+  for the contract on this method's @racket[get-token] argument.
+ }
+}
 
 @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
   This mixin adds coloring functionality to the mode.

gui-doc/scribblings/framework/text.scrbl

@@ -1,6 +1,6 @@
 #lang scribble/doc
 @(require scribble/manual scribble/extract)
-@(require (for-label framework racket/gui))
+@(require (for-label framework racket/gui racket/contract/base))
 @title{Text}
 
 @definterface[text:basic<%> (editor:basic<%> text%)]{
@@ -139,24 +139,43 @@
   }
 
   @defmethod[(move/copy-to-edit [dest-text (is-a?/c text%)]
-                                [start exact-integer?]
+                                [start natural?]
-                                [end exact-integer?]
+                                [end (and/c natural? (>=/c start))]
-                                [dest-pos exact-integer?]
+                                [dest-pos natural?]
                                 [#:try-to-move? try-to-move? boolean? #t])
              void?]{
-    This moves or copies text and snips to another edit.
+    This moves or copies text and snips to @racket[dest-text].
 
-    Moves or copies from the edit starting at @racket[start] and ending at
+    Moves or copies from @racket[this] 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].
+    starting at location @racket[dest-pos]. If @racket[start] and @racket[end]
+    are equal then nothing is moved or copied.
 
-    If @racket[try-to-move] is @racket[#t], then the snips are removed;
+    If @racket[try-to-move?] is @racket[#t], then the snips are removed;
-    and if it is @racket[#f], then they are copied.
+    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 a snip refused to be moved, it will be copied and deleted from the editor,
+    If a snip refuses 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
@@ -539,7 +558,7 @@
 @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
   Any object matching this interface can be searched.
 
-  @defmethod[(set-searching-state [str (or/c #f (and/c string? (not/c "")))]
+  @defmethod[(set-searching-state [str (or/c #f non-empty-string?)]
                                   [cs? boolean?]
                                   [replace-mode? boolean?]
                                   [notify-frame? boolean?])
@@ -576,11 +595,24 @@
     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?]{
@@ -589,8 +621,13 @@
   }
 
  @defmethod[(finish-pending-search-work) void?]{
-    Finishes any pending work in computing and
+  Finishes any pending work in computing and drawing the
-    drawing the search bubbles.
+  search bubbles.
+
+  Call this method to ensure that the results from any of
+  @method[text:searching<%> get-search-hit-count],
+  @method[text:searching<%> get-replace-search-hit], or
+  @method[text:searching<%> get-search-bubbles] are correct.
  }
 
   @defmethod[(get-search-bubbles)
@@ -603,6 +640,12 @@
     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.
   }
 }
@@ -1414,7 +1457,7 @@
   }
 }
 
-@defmixin[text:line-numbers-mixin (text%) (text:line-numbers<%>)]{
+@defmixin[text:line-numbers-mixin (text% editor:standard-style-list<%>) (text:line-numbers<%>)]{
 
   @defmethod*[#:mode override (((on-paint) void?))]{
     Draws the line numbers.

gui-doc/scribblings/gui/blurbs.rkt

@@ -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 X, mnemonic underlines are
+      indicate a keyboard mnemonic. (Under Mac OS, 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

gui-doc/scribblings/gui/button-class.scrbl

@@ -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 X, mnemonic underlines are
+indicate a keyboard mnemonic. (On Mac OS, 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,14 +45,13 @@ 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 X, a parenthesized mnemonic character is
+underlining). On Mac OS, 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.

gui-doc/scribblings/gui/canvas-class.scrbl

@@ -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 X, the result can be the same as @method[window<%>
+Mac OS, 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.
 

gui-doc/scribblings/gui/canvas-intf.scrbl

@@ -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 X resides on a Retina display, it
+For example, when a canvas on Mac OS 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 X, however, the viewport will match
+the @racket['gl] style. On Mac OS, 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 X, enables or disables space for a resize tab at the
+On Mac OS, 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

gui-doc/scribblings/gui/clipboard-client-class.scrbl

@@ -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 X, only four characters for @racket[format] are ever used.)
+ Mac OS, 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.

gui-doc/scribblings/gui/clipboard-intf.scrbl

@@ -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 X, @racket[the-x-selection-clipboard] is
+On Windows and Mac OS, @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 X),
+Gets the current clipboard contents as a bitmap (Windows, Mac OS),
  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 X)
+Changes the current clipboard contents to @racket[new-bitmap] (Windows, Mac OS)
  and releases the current clipboard client (if any).
 
 See @|timediscuss| for

gui-doc/scribblings/gui/dialog-class.scrbl

@@ -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 X (and with some Unix window managers)
+ used. On Windows and Mac OS (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 X), or grow
+  window (Windows), ability to resize the window (Mac OS), or grow
-  box in the bottom right corner (older Mac OS X)}
+  box in the bottom right corner (older Mac OS)}
 
  @item{@racket['no-sheet] --- uses a movable window for the dialog,
- even if a parent window is provided (Mac OS X)}
+ even if a parent window is provided (Mac OS)}
 
  @item{@racket['close-button] --- include a close button in the 
- dialog's title bar, which would not normally be included (Mac OS X)}
+ dialog's title bar, which would not normally be included (Mac OS)}
 
 ]
 

gui-doc/scribblings/gui/dialog-funcs.scrbl

@@ -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 X, if the @racket[style] list
+ native dialog.  On Mac OS, 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 X, suffix names are extracted from all globs that match a
+ On Mac OS, 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 X 10.5 and later, if @racket[extension] is not
+On Mac OS 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 X 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 X versions before 10.5, the returned path will get a
+On Mac OS 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 X, where @racket['enter-packages]
+ matters only on Mac OS, 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,8 +295,7 @@ 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
+ this one. On Windows, this button is leftmost; on Unix and Mac OS, it is rightmost. (See also
- X, it is rightmost. (See also
  @racket[system-position-ok-before-cancel?].) Use this button for
  dialogs that contain only one button.}
 
@@ -305,7 +304,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 X, it is left-aligned in the dialog). Use this button only
+ Mac OS, it is left-aligned in the dialog). Use this button only
  for three-button dialogs.}
 
 ]

gui-doc/scribblings/gui/editor-funcs.scrbl

@@ -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 X. See also
+mapping on Mac OS. See also
 @xmethod[keymap% map-function].
 
 
@@ -187,8 +187,7 @@ 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.
 
 
 

gui-doc/scribblings/gui/editor-intf.scrbl

@@ -30,6 +30,10 @@ 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
@@ -2060,7 +2064,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 X, the file's type signature is set to @racket["TEXT"]
+On Mac OS, the file's type signature is set to @racket["TEXT"]
  for a text-format file or @racket["WXME"] for a standard-format
  (binary) file.
 

gui-doc/scribblings/gui/editor-overview.scrbl

@@ -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 operations are available. We
+ into the editor, but no cut-and-paste or undo operations are
- can support all of the standard operations on an editor via the
+ available. We can support all of the standard operations on an editor
- menu bar:
+ via the menu bar:
 
 @racketblock[
 (define mb (new menu-bar% [parent f]))
@@ -71,16 +71,20 @@ 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 the user can even
+Now, the standard cut-and-paste operations work and so does undo, and
- set font styles. The user can also insert an embedded editor by
+ the user can even set font styles. The editor is created with no undo
- selecting @onscreen{Insert Text} from the @onscreen{Edit} menu; after
+ history stack, @method[editor<%> set-max-undo-history] is used to set
- selecting the menu item, a box appears in the editor with the caret
+ a non-zero stack, so undo operations can be recorded. The user can
- inside. Typing with the caret in the box stretches the box as text is
+ also insert an embedded editor by selecting @onscreen{Insert Text}
- added, and font operations apply wherever the caret is active. Text
+ from the @onscreen{Edit} menu; after selecting the menu item, a box
- on the outside of the box is rearranged as the box changes
+ appears in the editor with the caret inside. Typing with the caret in
- sizes. Note that the box itself can be copied and pasted.
+ 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
@@ -586,7 +590,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 X, and
+ (linefeed on Unix and Mac OS, 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.}

gui-doc/scribblings/gui/eventspace-funcs.scrbl

@@ -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 X) key combination. Returns
+ Shift-Ctl-C (Unix, Windows) or Cmd-. (Mac OS) 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 X), but it currently
+or disable special Control key handling (Mac OS), 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 X). When
+Enables or disables special Option key handling (Mac OS). 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

gui-doc/scribblings/gui/font-funcs.scrbl

@@ -7,7 +7,7 @@
 
 This font is the default for @racket[popup-menu%] objects.
 
-On Mac OS X, this font is slightly larger than
+On Mac OS, 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 X, this font is slightly
+ already relatively small. On Unix and Mac OS, 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 X, this font is slightly smaller than
+On Mac OS, 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].

gui-doc/scribblings/gui/frame-class.scrbl

@@ -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 X), or grow box in the bottom right corner (older Mac OS X)}
+  OS), or grow box in the bottom right corner (older Mac OS)}
 
  @item{@racket['no-caption] --- omits the title bar for the frame
- (Windows, Mac OS X, Unix)}
+ (Windows, Mac OS, 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 X 10.6 and earlier); a click on the toolbar button triggers
+ frame's title bar (Mac OS 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 X) or asks the window manager to make
+ the frame is active (Mac OS) 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 X, Unix); on Mac OS X, a floating frame
+ other non-floating windows (Windows, Mac OS, Unix); on Mac OS, 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 X)}
+ @item{@racket['metal] --- ignored (formerly supported for Mac OS)}
 
  @item{@racket['fullscreen-button] --- includes a button on the
- frame's title bar to put the frame in fullscreen mode (Mac OS X 10.7 and later)}
+ frame's title bar to put the frame in fullscreen mode (Mac OS 10.7 and later)}
 
  @item{@racket['fullscreen-aux] --- allows the frame to accompany
- another that is in fullscreen mode (Mac OS X 10.7 and later)}
+ another that is in fullscreen mode (Mac OS 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 X, the @racket[frame%] must be created with the style
+On Mac OS, the @racket[frame%] must be created with the style
- @racket['fullscreen-button] for fullscreen mode to work, and Mac OS X
+ @racket['fullscreen-button] for fullscreen mode to work, and Mac OS
  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 X.}]}
+                                to not imply @method[window<%> show] on Windows and Mac OS.}]}
 
 @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 X, returns @racket[#t] if the frame is
+On Windows and Mac OS, 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 X; the
+Maximizes or restores the frame on Windows and Mac OS; 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 X, the modification state is reflected as a dot in the
+ On Mac OS, 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 X, called when the user clicks the toolbar button on a
+On Mac OS, called when the user clicks the toolbar button on a
  frame created with the @indexed-racket['toolbar-button] style.
 
 }

gui-doc/scribblings/gui/global-draw-funcs.scrbl

@@ -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 X in Retina display mode, and on Windows or Unix it can be a value
+on Mac OS 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 X or Unix, the result can change at any time.  See also
+On Mac OS 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 X, the result can change at any time.
+On Windows and Mac OS, 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 X, the result is
+ always @racket[0] and @racket[0]; on Mac OS, 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 X). On Unix, for
+ the task bar (Windows) or menu bar and dock (Mac OS). 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 X, this size does not include the menu bar or
+ default.  On Mac OS, this size does not include the menu bar or
  dock area by default.
 
-On Windows and Mac OS X, if the optional argument is true and @racket[monitor] is @racket[0], then
+On Windows and Mac OS, 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

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

@@ -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 X, a
+ as a container. On older version of Mac OS, 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 X, a @racket[grow-box-spacer-pane%] has zero width and
+ Windows, Unix, and recent Mac OS, 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.
 

gui-doc/scribblings/gui/key-event-class.scrbl

@@ -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 X) key was down for
+Returns @racket[#t] if the Option (Mac OS) 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 X, if a Control-key press is combined with a mouse button
+On Mac OS, 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 X)}
+      (which is reported as @racket['numpad-enter] Unix and Mac OS)}
 
  @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 X, the key code is computed without
+ of the Shift key. On Mac OS, 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,8 +225,7 @@ 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
+Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS) key was down for the event.
- X) key was down for the event.
 
 }
 
@@ -285,8 +284,7 @@ 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
+with Control) on Windows and Unix, or the Option key on Mac OS. The @method[key-event% get-other-shift-altgr-key-code] method
-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.
 
@@ -303,7 +301,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 X and Unix, alternate
+ ASCII digits, and ASCII symbols. On Mac OS and Unix, alternate
  mappings are usually available.
 
 }
@@ -334,7 +332,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 X) key was down for the event.  When
+Sets whether the Option (Mac OS) 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]).
 
@@ -352,7 +350,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 X, if a control-key press is combined with a mouse button
+On Mac OS, 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].
@@ -388,7 +386,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 X) key
+Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key
  was down for the event.
 
 }

gui-doc/scribblings/gui/keymap-class.scrbl

@@ -32,7 +32,7 @@ Creates an empty keymap.
 }
 
 @defmethod[(add-function [name string?]
-                         [func (any/c (is-a?/c event%) . -> . any/c)])
+                         [func (any/c (is-a?/c event%) . -> . any)])
            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 X: Option}
+ @item{@litchar{a:} --- Mac OS: Option}
 
- @item{@litchar{m:} --- Windows: Alt; Unix: Meta; Mac OS X: Command, when
+ @item{@litchar{m:} --- Windows: Alt; Unix: Meta; Mac OS: Command, when
  @racket[map-command-as-meta-key] produces @racket[#t]}
 
- @item{@litchar{d:} --- Mac OS X: Command}
+ @item{@litchar{d:} --- Mac OS: 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 X, then ASCII letters are not
+ @litchar{d:} is included on Mac OS, 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 X).
+ (on Mac OS).
 
 A state can match multiple state strings mapped in a keymap (or keymap
  chain); when a state matches multiple state strings, a mapping is

gui-doc/scribblings/gui/labelled-menu-item-intf.scrbl

@@ -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 X, @litchar{&}s in the label are parsed in
+ @litchar{&}. On Mac OS, @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 X, a parenthesized mnemonic character is
+ displayed. On Mac OS, 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

gui-doc/scribblings/gui/message-class.scrbl

@@ -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 X) or a generic ``info'' icon (X),
+ icon (Windows and Mac OS) or a generic ``info'' icon (X),
  @racket['caution] is a caution-sign icon, and @racket['stop] is a
  stop-sign icon.
 

gui-doc/scribblings/gui/miscwin-funcs.scrbl

@@ -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 X.
+Gets or sets the creator and type of a file in Mac OS.
 
 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 X, the
+On Windows, the default is @racket['(ctl)]. On Mac OS, 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 X)}
+ @item{@racket['cocoa] (Mac OS)}
 
  @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 X 10.5 and earlier, mouse-button information is
+@margin-note{On Mac OS 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 X when the main monitor is in Retina display
+In particular, on Mac OS 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 X, Quicktime is used to play sounds; most sound
+On Mac OS, 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 X and Unix.}
+returns @racket[#f] on Mac OS and Unix.}
 
 
 @defthing[the-clipboard (is-a?/c clipboard<%>)]{

gui-doc/scribblings/gui/mouse-event-class.scrbl

@@ -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 X: click with control key pressed)}
+@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 X: release with control key pressed)}
+@item{@racket['right-up] --- right mouse button released (Mac OS: 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 X) key was down for the
+Returns @racket[#t] if the Option (Mac OS) 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 X, if a control-key press is combined with a mouse button
+On Mac OS, 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,8 +166,7 @@ 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
+Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS) key was down for the event.
- X) key was down for the event.
 
 }
 
@@ -175,7 +174,7 @@ Returns @racket[#t] if the Meta (Unix), Alt (Windows), or Command (Mac OS
            boolean?]{
 
 Returns @racket[#t] if the middle mouse button was down (but not
- pressed) for the event.  On Mac OS X, a middle-button click is
+ pressed) for the event.  On Mac OS, a middle-button click is
  impossible.
 
 }
@@ -205,7 +204,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 X, a control-click combination
+ pressed) for the event. On Mac OS, a control-click combination
  is treated as a right-button click.
 
 }
@@ -255,7 +254,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 X) key was down for the event.  When
+Sets whether the Option (Mac OS) 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]).
 
@@ -273,7 +272,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 X, if a control-key press is combined with a mouse button
+On Mac OS, 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].
@@ -301,7 +300,7 @@ the event.
 @defmethod[(set-meta-down [down? any/c])
            void?]{
 
-Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS X) key
+Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS) key
  was down for the event.
 
 }
@@ -310,7 +309,7 @@ Sets whether the Meta (Unix), Alt (Windows), or Command (Mac OS X) key
            void?]{
 
 Sets whether the middle mouse button was down (but not pressed) for
- the event.  On Mac OS X, a middle-button click is impossible.
+ the event.  On Mac OS, a middle-button click is impossible.
 
 }
 
@@ -339,7 +338,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 X, a control-click combination by the user is
+ event. On Mac OS, a control-click combination by the user is
  treated as a right-button click.
 
 }

gui-doc/scribblings/gui/pasteboard-class.scrbl

@@ -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 X) into the editor.  This
+ the clipboard on Windows and Mac OS) 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].

gui-doc/scribblings/gui/selectable-menu-item-intf.scrbl

@@ -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 X only)}
+@item{@racket['cmd] --- Command (Mac OS only)}
 @item{@racket['meta] --- Meta (Unix only)}
 @item{@racket['ctl] --- Control}
 @item{@racket['shift] --- Shift}
-@item{@racket['option] --- Option (Mac OS X only)}
+@item{@racket['option] --- Option (Mac OS only)}
 ]
 
 On Unix, at most one of @racket['alt] and @racket['meta] can be

gui-doc/scribblings/gui/snip-example.scrbl

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

gui-doc/scribblings/gui/system-menu-funcs.scrbl

@@ -6,14 +6,14 @@
 
 @defproc[(current-eventspace-has-standard-menus?)
          boolean?]{
-Returns @racket[#t] for Mac OS X when the current eventspace is the
+Returns @racket[#t] for Mac OS 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 X, the application
+ item in a frame's menu. On Mac OS, 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 X when the current eventspace is the
+Returns @racket[#t] for Mac OS 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,8 +41,7 @@ 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
+user selects the application @onscreen{About} menu item on Mac OS.  The thunk is always called in the initial eventspace's
-X.  The thunk is always called in the initial eventspace's
 handler thread (as a callback).
 
 The default handler displays a generic Racket dialog.
@@ -59,7 +58,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 X
+ retrieves or installs a procedure that is called on Mac OS
  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
@@ -77,7 +76,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 X, if an application is started @emph{without} files, then
+On Mac OS, 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
@@ -92,7 +91,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 X.  The
+ the application @onscreen{Preferences} menu item on Mac OS.  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.
@@ -111,7 +110,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 X, or when shutting down the machine in Windows). The
+ item on Mac OS, 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
@@ -139,7 +138,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 X without supplying any initial files (e.g.,
+ the application on Mac OS without supplying any initial files (e.g.,
  by double-clicking the application icon instead of double-clicking
  files that are handled by the application).
 

gui-doc/scribblings/gui/text-class.scrbl

@@ -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 X) into the editor.  This method is
+ clipboard on Windows or Mac OS) 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 string?]
+@defmethod[(find-string [str non-empty-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 string?]
+@defmethod[(find-string-embedded [str non-empty-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 string?]
+@defmethod[(find-string-all [str non-empty-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 string?]
+@defmethod[(find-string-embedded-all [str non-empty-string?]
                                      [direction (or/c 'forward 'backward) 'forward]
                                      [start (or/c exact-nonnegative-integer? 'start) 'start]
                                      [end (or/c exact-nonnegative-integer? 'eof) 'eof]

gui-doc/scribblings/gui/top-level-window-intf.scrbl

@@ -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 X, a child of a floating frames can have the
+ window. On Mac OS, 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 X). In that case, this method is called for the most
+ on Mac OS). 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 X)}
+ Mac OS)}
 
  @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 X --- both icons are ignored.}
+ @item{Mac OS --- 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

gui-doc/scribblings/gui/win-overview.scrbl

@@ -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, than the abort
+For example, if a button callback raises an exception, then 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 X, screen sizes are described to users in terms of drawing
+On Mac OS, 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

gui-doc/scribblings/gui/window-intf.scrbl

@@ -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 X, the screen coordinates start with @math{(0, 0)} at the
+On Mac OS, 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 X: @tt{NSView}}
+ @item{Mac OS: @tt{NSView}}
 
  @item{Unix: @tt{GtkWidget}}
 
@@ -139,7 +139,7 @@ platform:
 
  @item{Windows: @tt{HWND}}
 
- @item{Mac OS X: @tt{NSWindow} for a @racket[top-level-window<%>] object,
+ @item{Mac OS: @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 X, when the application is running and user
+On Mac OS, 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

gui-doc/scribblings/gui/wxme.scrbl

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

gui-lib/framework/gui-utils.rkt

@@ -230,7 +230,8 @@
           (λ () (thunk))
           (λ () (cursor-off))))])))
 
-(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t])
+(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t]
+                         #:dialog-mixin [dialog-mixin values])
   (define key-closed #f)
   (define (unsaved-warning-mixin %)
     (class %
@@ -265,24 +266,24 @@
          '(default=2 caution))
      2
      #:dialog-mixin (if (equal? (system-type) 'macosx)
-                        unsaved-warning-mixin
+                        (compose unsaved-warning-mixin dialog-mixin)
-                        values)))
+                        dialog-mixin)))
   (or key-closed
       (case mb-res
         [(1) 'save]
         [(2) 'cancel]
         [(3) 'continue])))
 
-(define get-choice
+(define (get-choice message
-  (lambda (message 
                     true-choice
                     false-choice
-           (title (string-constant warning))
+                    [title (string-constant warning)]
-           (default-result 'disallow-close)
+                    [default-result 'disallow-close]
-           (parent #f)
+                    [parent #f]
-           (style 'app)
+                    [style 'app]
-           (checkbox-proc #f)
+                    [checkbox-proc #f]
-           (checkbox-label (string-constant dont-ask-again)))
+                    [checkbox-label (string-constant dont-ask-again)]
+                    #:dialog-mixin [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)
@@ -293,11 +294,13 @@
         (let-values ([(mb-res checked)
                       (message+check-box/custom title message checkbox-label
                                                 true-choice false-choice #f
-                                                  parent style default-result)])
+                                                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))))))
+                                    parent style default-result
+                                    #:dialog-mixin dialog-mixin)))))
 
 ;; manual renaming
 (define gui-utils:trim-string trim-string)
@@ -383,7 +386,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 X and unix, the confirmation action
+    to suit the platform. Under Mac OS 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.
@@ -490,12 +493,14 @@
     (or/c false/c
           (is-a?/c frame%)
           (is-a?/c dialog%))
-    boolean?)
+    boolean?
+    #:dialog-mixin (make-mixin-contract dialog%))
    (symbols 'continue 'save 'cancel))
   ((filename action)
    ((can-save-now? #f)
     (parent #f)
-    (cancel? #t)))
+    (cancel? #t)
+    (dialog-mixin values)))
   
   @{This displays a dialog that warns the user of a unsaved file.
     
@@ -512,6 +517,10 @@
     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
@@ -525,7 +534,8 @@
         (symbols 'app 'caution 'stop)
         (or/c false/c (case-> (boolean? . -> . void?)
                               (-> boolean?)))
-        string?)
+        string?
+        #:dialog-mixin (make-mixin-contract dialog%))
        any/c)
   ((message true-choice false-choice)
    ((title (string-constant warning))
@@ -533,7 +543,8 @@
     (parent #f)
     (style 'app)
     (checkbox-proc #f)
-    (checkbox-label (string-constant dont-ask-again))))
+    (checkbox-label (string-constant dont-ask-again))
+    (dialog-mixin values)))
   
   @{Opens a dialog that presents a binary choice to the user. The user is
     forced to choose between these two options, ie cancelling or closing the
@@ -565,7 +576,14 @@
     (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.})
+    caller's responsibility to avoid the dialog if not needed.
+
+    The @racket[dialog-mixin] argument is passed to @racket[message-box/custom]
+    or @racket[message+check-box/custom].
+
+    @history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
+
+    })
  
  (proc-doc/names
   gui-utils:get-clicked-clickback-delta

gui-lib/framework/main.rkt

@@ -193,23 +193,39 @@
 
  (proc-doc/names
   number-snip:make-repeating-decimal-snip
-  (real? boolean? . -> . (is-a?/c snip%))
+  (-> real? boolean? number-snip:is-number-snip?)
   (num show-prefix?)
-  @{Makes a number snip that shows the decimal expansion for @racket[number].
+  @{Makes a @tech{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? . -> . (is-a?/c snip%))
+  (-> real? boolean? number-snip:is-number-snip?)
   (num show-prefix-in-decimal-view?)
-  @{Makes a number snip that shows a fractional view of @racket[number].
+  @{Makes a @tech{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%)

gui-lib/framework/preferences.rkt

@@ -28,7 +28,10 @@ the state transitions / contracts are:
 
 (require scribble/srcdoc
          racket/contract/base racket/file)
-(require/doc racket/base scribble/manual (for-label racket/serialize))
+(require/doc racket/base
+             scribble/manual
+             scribble/example
+             (for-label racket/serialize))
 
 (define-struct (exn:unknown-preference exn) ())
 
@@ -43,22 +46,30 @@ the state transitions / contracts are:
 
 ;; preferences : hash-table[sym -o> any]
 ;;   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]
-(define defaults (make-hasheq))
+(struct preferences:layer (preferences marshall-unmarshall callbacks defaults prev))
 
-;; these four functions determine the state of a preference
+(define (preferences:new-layer prev)
-(define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
+  (preferences:layer (make-hasheq) (make-hasheq) (make-hasheq) (make-hasheq) prev))
-(define (preferences:default-set? pref) (hash-has-key? defaults pref))
+(define preferences:current-layer (make-parameter (preferences:new-layer #f)))
-(define (pref-can-init? pref)
+
-  (not (hash-has-key? preferences pref)))
+(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)))
 
 ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
 (define-struct un/marshall (marshall unmarshall))
@@ -71,7 +82,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))
+(define-struct pref-callback (cb) #:transparent)
 
 ;; used to detect missing hash entries
 (define none (gensym 'none))
@@ -80,35 +91,43 @@ the state transitions / contracts are:
 ;; return the current value of the preference `p'
 ;; exported
 (define (preferences:get p)
-  (define v (hash-ref preferences p none))
+  (define pref-state (find-layer p))
-  (cond
+  (when (or (not pref-state)
-    ;; if this is found, we can just return it immediately
+            (not (hash-has-key? (preferences:layer-defaults pref-state) p)))
-    [(not (eq? v none))
-     v]
-    ;; first time reading this, check the file & unmarshall value, if
-    ;; it's not there, use the default
-    [(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)]))
+     p))
+  (define preferences (preferences:layer-preferences pref-state))
+  (define v (hash-ref preferences p none))
+  (cond
+    ;; 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]))
 
 ;; 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 p)
+(define (read-pref-from-file defaults p)
-  (let ([defaults (hash-ref defaults p)])
   (let loop ([syms (cons p (default-aliases defaults))]
              [rewriters (cons values (default-rewrite-aliases defaults))])
     (cond
@@ -118,7 +137,7 @@ the state transitions / contracts are:
          ((car rewriters)
           ((preferences:low-level-get-preference)
            (add-pref-prefix (car syms))
-             (lambda () (k (loop (cdr syms) (cdr rewriters)))))))]))))
+           (lambda () (k (loop (cdr syms) (cdr rewriters)))))))])))
 
 ;; set : symbol any -> void
 ;; updates the preference
@@ -133,37 +152,37 @@ the state transitions / contracts are:
    (λ ()
      (call-pref-save-callbacks #t))
    (λ ()
-     (for-each
+     (for ([p (in-list ps)]
-      (λ (p value)
+           [value (in-list values)])
+       (define pref-state (find-layer p))
        (cond
-          [(preferences:default-set? p)
+         [pref-state
-           (define default (hash-ref defaults p))
+          (define default (hash-ref (preferences:layer-defaults pref-state) p))
           (define checker? (default-checker default))
           (unless (checker? value)
             (error 'preferences:set
                    (string-append
                     "new value doesn't satisfy preferences:set-default predicate\n"
-                     "  pref sym: ~v\n"
+                    "  pref symbol: ~e\n"
                     "  given: ~e\n"
                     "  predicate: ~e")
                    p value checker?))
-             (check-callbacks p value)
+          (check-callbacks pref-state p value)
-             (hash-set! preferences p value)]
+          (hash-set! (preferences:layer-preferences pref-state) p value)]
-          [(not (preferences:default-set? p))
+         [else
           (raise-unknown-preference-error
            'preferences:set
            (string-append
             "cannot set preference before setting default"
-             "  pref sym: ~e\n"
+            "  pref symbol: ~e\n"
             "  given: ~e")
            p
            value)]))
-      ps values)
      ((preferences:low-level-put-preferences)
       (map add-pref-prefix ps)
-      (map (λ (p value) (marshall-pref p value))
+      (for/list ([p (in-list ps)]
-           ps
+                 [value (in-list values)])
-           values))
+        (marshall-pref p value)))
      (void))
    (λ ()
      (call-pref-save-callbacks #f))))
@@ -201,11 +220,13 @@ the state transitions / contracts are:
           (current-continuation-marks))))
 
 ;; add-callback : sym (-> void) -> void
-(define preferences:add-callback 
+(define (preferences:add-callback p callback [weak? #f])
-  (lambda (p callback [weak? #f])
+  (define pref-state (or (find-layer p) (preferences:current-layer)))
-    (let ([new-cb (make-pref-callback (if weak?
+  (define callbacks (preferences:layer-callbacks pref-state))
+  (define new-cb
+    (make-pref-callback (if weak?
                             (impersonator-ephemeron callback)
-                                          callback))])
+                            callback)))
   (hash-set! callbacks
              p
              (append
@@ -224,10 +245,11 @@ the state transitions / contracts are:
               [(eq? callback new-cb)
                (loop (cdr callbacks))]
               [else
-                   (cons (car callbacks) (loop (cdr callbacks)))]))])))))))
+               (cons (car callbacks) (loop (cdr callbacks)))]))])))))
 
-;; check-callbacks : sym val -> void
+;; check-callbacks : pref-state sym val -> void
-(define (check-callbacks p value)
+(define (check-callbacks pref-state p value)
+  (define callbacks (preferences:layer-callbacks pref-state))
   (define new-callbacks
     (let loop ([callbacks (hash-ref callbacks p '())])
       (cond
@@ -252,106 +274,137 @@ 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
-    [(and (preferences:default-set? p)
+    [pref-state
-          (not (pref-un/marshall-set? p))
+     (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
-          (pref-can-init? p))
+     (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))]
-    [(not (preferences:default-set? p))
+       [pref-un/marshall-set?
-     (error 'preferences:set-un/marshall
-            "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))
+       [(not pref-can-init?)
-     (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)]))
+        (error 'preferences:set-un/marshall "the preference ~e cannot be configured any more" p)])]
-
+    [else
-(define (preferences:restore-defaults)
+     (error 'preferences:set-un/marshall
-  (hash-for-each
+            "must call preferences:set-default for ~s before calling set-un/marshall for ~s"
-   defaults
+            p p)]))
-   (λ (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 (lambda (x) values) aliases)])
+                                 #:rewrite-aliases [rewrite-aliases (map (λ (x) values) aliases)])
-  (cond
+  (define pref-state (or (find-layer p) (preferences:current-layer)))
-    [(and (not (preferences:default-set? p))
+  (define defaults (preferences:layer-defaults pref-state))
-          (pref-can-init? p))
+  (when (hash-has-key? defaults p)
-     (define default-okay? (checker default-value))
+    (error 'preferences:set-default
-     (unless default-okay?
-       (error 'set-default 
            (string-append
-               "checker doesn't match default\n"
+            "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"
-               "  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"
+           (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))]
+  (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
-    (let* ([marshaller
+    (define marshaller
       (un/marshall-marshall
-             (hash-ref marshall-unmarshall p (λ () (k value))))])
+       (hash-ref (preferences:layer-marshall-unmarshall pref-state)
-      (marshaller value))))
+                 p
+                 (λ () (k value)))))
+    (marshaller value)))
 
-;; unmarshall-pref : symbol marshalled -> any
+;; unmarshall-pref : pref-state symbol marshalled (any -> bool) any -> any
 ;; unmarshalls a preference read from the disk
-(define (unmarshall-pref p data)
+(define (unmarshall-pref pref-state p data the-checker the-default-value)
-  (let* ([un/marshall (hash-ref marshall-unmarshall p #f)]
+  (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
-         [result (if un/marshall
+  (define un/marshall (hash-ref marshall-unmarshall p #f))
+  (define result
+    (if un/marshall
         ((un/marshall-unmarshall un/marshall) data)
-                     data)]
+        data))
-         [default (hash-ref defaults p)])
+  (if (the-checker result)
-    (if ((default-checker default) result)
       result
-        (default-value default))))
+      the-default-value))
 
 ;; 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
-    (let* ([un/marshaller (hash-ref marshall-unmarshall p (λ () (k value)))]
+    (define pref-state (find-layer p))
-           [default (hash-ref defaults p)]
+    (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state))
-           [marsh (un/marshall-marshall un/marshaller)]
+    (define un/marshaller (hash-ref marshall-unmarshall p (λ () (k value))))
-           [unmarsh (un/marshall-unmarshall un/marshaller)]
+    (define default (hash-ref (preferences:layer-defaults pref-state) p))
-           [marshalled (marsh value)]
+    (define marsh (un/marshall-marshall un/marshaller))
-           [copy (unmarsh marshalled)])
+    (define unmarsh (un/marshall-unmarshall un/marshaller))
+    (define marshalled (marsh value))
+    (define copy (unmarsh marshalled))
     (if ((default-checker default) copy)
         copy
-          value))))
+        value)))
+
+(define (preferences:restore-defaults)
+  (let loop ([prefs-state (preferences:current-layer)])
+    (when prefs-state
+      (for ([(p def) (in-hash (preferences:layer-defaults prefs-state))])
+        (preferences:set p (default-value def)))
+      (loop (preferences:layer-prev prefs-state)))))
 
 (define-struct preferences:snapshot (x))
 (define (preferences:get-prefs-snapshot)
   (make-preferences:snapshot
-   (hash-map defaults 
+   (let loop ([prefs-state (preferences:current-layer)]
-             (λ (k v) (cons k (copy-pref-value k (preferences:get k)))))))
+              [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]))))
 
 (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
@@ -414,6 +467,10 @@ 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
@@ -505,13 +562,19 @@ 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 
+  @{Registers @racket[callback] to run twice for each call
-              before the preferences file is written, with @racket[#t], and once after it is written, with
+ to @racket[preferences:set]---once before the preferences
-              @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. 
+ file is written, with @racket[#t], and once after it is
-              Caveats:
+ written, with @racket[#f]. Registration returns a key for
-              @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].}
+ use with @racket[preferences:unregister-save-callback].
-                       @item{Pre- and post-write notifications are not necessarily paired; unregistration
+ Caveats: @itemize{
-                             may cancel the post-write notification before it occurs.}}})
+  @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
@@ -539,7 +602,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].
@@ -586,4 +649,64 @@ 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].}))
+    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"]})
+ )

gui-lib/framework/private/autosave.rkt

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

gui-lib/framework/private/color-prefs.rkt

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

gui-lib/framework/private/color.rkt

@@ -27,7 +27,8 @@ added get-regions
         [prefix mode: framework:mode^]
         [prefix text: framework:text^]
         [prefix color-prefs: framework:color-prefs^]
-        [prefix racket: framework:racket^])
+        [prefix racket: framework:racket^]
+        [prefix number-snip: framework:number-snip/int^])
 
 (export (rename framework:color^
                 (-text<%> text<%>)
@@ -208,7 +209,9 @@ added get-regions
                               (and (null? (cdr regions))
                                    (eq? 'end (list-ref region 1)))))
                (error 'reset-regions 
-                      "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e" 
+                      (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")
                       region
                       regions))
              (unless (and (<= pos (list-ref region 0))
@@ -261,13 +264,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 ---------------------------
@@ -337,7 +340,11 @@ added get-regions
            (open-input-text-editor this 
                                    (lexer-state-current-pos ls)
                                    (lexer-state-end-pos ls)
-                                   (λ (x) #f)))
+                                   (λ (x)
+                                     (cond
+                                       [(number-snip:is-number-snip? x)
+                                        x]
+                                       [else #f]))))
          (port-count-lines! in)
          (continue-re-tokenize start-time ok-to-stop? ls in
                                (lexer-state-current-pos ls)
@@ -357,7 +364,8 @@ 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)
@@ -371,10 +379,12 @@ 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)
@@ -385,7 +395,9 @@ 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
@@ -403,7 +415,8 @@ 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)))
@@ -417,7 +430,8 @@ 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
@@ -497,7 +511,8 @@ 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
+             (set-lexer-state-current-lexer-mode!
+              ls
               (if (= start (lexer-state-start-pos ls))
                   #f
                   (begin
@@ -524,7 +539,8 @@ 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! 
@@ -593,7 +609,7 @@ added get-regions
             (loop)))))
     
     ;; See docs
-    (define/public (start-colorer token-sym->style- get-token- pairs-)
+    (define/private (_start-colorer token-sym->style- get-token- pairs-)
       (unless force-stop?
         (set! stopped? #f)
         (reset-tokens)
@@ -615,6 +631,9 @@ 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))
@@ -665,7 +684,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)
@@ -1037,9 +1056,6 @@ 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
@@ -1306,7 +1322,7 @@ added get-regions
 
 (define -text% (text-mixin text:keymap%))
 
-(define -text-mode<%> (interface ()))
+(define -text-mode<%> (interface () set-get-token))
 
 (define text-mode-mixin
   (mixin (mode:surrogate-text<%>) (-text-mode<%>)
@@ -1324,6 +1340,9 @@ 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%))

gui-lib/framework/private/editor.rkt

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

gui-lib/framework/private/exit.rkt

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

gui-lib/framework/private/frame.rkt

@@ -738,6 +738,25 @@
 
 (define magic-space 25)
 
+(define-local-member-name get-memory-use-canvas)
+(define memory-use-timer-cell (make-thread-cell #f))
+(define (update-memory-use-canvases)
+  (define found-any? #f)
+  (for ([window (in-list (get-top-level-windows))])
+    (when (is-a? window frame:info<%>)
+      (set! found-any? #t)
+      (send (send window get-memory-use-canvas) update-memory-use-if-bigish-change)))
+  (unless found-any?
+    (send (thread-cell-ref memory-use-timer-cell) stop)
+    (thread-cell-set! memory-use-timer-cell #f)))
+(define (maybe-create-memory-use-timer)
+  (unless (thread-cell-ref memory-use-timer-cell)
+    (when (eq? (current-thread) (eventspace-handler-thread (current-eventspace)))
+      (thread-cell-set! memory-use-timer-cell
+                        (new timer%
+                             [notify-callback update-memory-use-canvases]
+                             [interval 1000])))))
+
 (define info-mixin
   (mixin (basic<%>) (info<%>)
     [define rest-panel 'uninitialized-root]
@@ -852,39 +871,20 @@
     (new grow-box-spacer-pane% [parent outer-info-panel])
     
     (define/public (get-info-panel) info-panel)
-    (define/public (update-memory-text)
+    (define/public (get-memory-use-canvas) this-frames-memory-canvas)
-      (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])]
+                       [stretchable-height #f])])
-           [ec (new position-canvas%
+      (set! this-frames-memory-canvas
+            (new memory-position-canvas%
                  [parent panel]
                  [button-up
                   (λ (evt)
@@ -894,13 +894,12 @@
                        (dynamic-require 'framework/private/follow-log #f)]
                       [else
                        (collect-garbage)
-                          (update-memory-text)]))]
+                       (update-memory-text)]))]))
-                    [init-width "99.99 MB"])])
+      (set! memory-canvases (cons this-frames-memory-canvas memory-canvases))
-      (set! memory-canvases (cons ec memory-canvases))
+      (maybe-create-memory-use-timer)
-      (update-memory-text)
       (set! memory-cleanup
             (λ ()
-              (set! memory-canvases (remq ec memory-canvases))))
+              (set! memory-canvases (remq this-frames-memory-canvas memory-canvases))))
       (send panel stretchable-width #f))
     
     (define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)]))
@@ -1021,6 +1020,37 @@
         (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<%>)
@@ -1509,7 +1539,8 @@
                          (string-constant no)
                          (string-constant are-you-sure-revert-title)
                          #f
-                         this))
+                         this
+                         #:dialog-mixin focus-table-mixin))
                 (revert))))
         #t))
     
@@ -2370,7 +2401,11 @@
     (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 (not hidden?)))
+    (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:create-replace-all?) #t)
 
     (define/override make-root-area-container
@@ -2538,9 +2573,14 @@
                     (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)
-                    (copy-over replace-edit 0 (send replace-edit last-position) found-txt start)
+                    (define revision-after (send found-txt get-revision-number))
-                    (loop found-txt (+ start (send replace-edit last-position)))))))
+                    (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))))))))
             (hash-for-each ht (λ (txt _) (send txt end-edit-sequence)))))))
                              
     (define/private (pop-all-the-way-out txt)
@@ -2747,8 +2787,6 @@
     (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)

gui-lib/framework/private/group.rkt

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

gui-lib/framework/private/main.rkt

@@ -25,6 +25,12 @@
 
 (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?)
@@ -553,21 +559,12 @@
 (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:default-text-color))
-    (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))))
-(editor:set-default-font-color 
- (color-prefs:lookup-in-color-scheme 'framework:default-text-color)
- (color-prefs:lookup-in-color-scheme 'framework:basic-canvas-background))
 
 (color-prefs:add-color-scheme-entry 'framework:misspelled-text-color "black" "white")
 

gui-lib/framework/private/number-snip.rkt

@@ -8,7 +8,7 @@
            file/convertible)
   
   (import mred^)
-  (export (rename framework:number-snip^
+  (export (rename framework:number-snip/int^
                   [-snip-class% snip-class%]))
   (init-depend mred^)
   
@@ -92,6 +92,9 @@
                        (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

gui-lib/framework/private/preferences.rkt

@@ -512,6 +512,11 @@ 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)))
 

gui-lib/framework/private/racket.rkt

@@ -1350,19 +1350,11 @@
       (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
-     (lambda (k v) (set! tabify-pref v)))
+     tabify-pref-callback
-    (define/private (racket-lexer-wrapper in offset mode)
+     #t)
-      (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
@@ -1372,12 +1364,41 @@
            (sup directory default-name))]
         [else (sup directory default-name)]))
 
-    (super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
+    (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)))
                (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)

gui-lib/framework/private/sig.rkt

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

gui-lib/framework/private/text.rkt

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

gui-lib/framework/test.rkt

@@ -1024,7 +1024,7 @@
   @method[canvas<%> on-event] method.
   Use @racket[test:button-push] to click on a button.
   
-  Under Mac OS X, @racket['right] corresponds to holding down the command
+  Under Mac OS, @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

gui-lib/info.rkt

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

gui-lib/mred/installer.rkt

@@ -26,7 +26,9 @@
     (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"))
@@ -43,7 +45,10 @@
           (make-gracket-launcher
            #:tether-mode tether-mode
            '("-I" "scheme/gui/init" "-z")
-           (prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
+           (prep-dir (mred-program-launcher-path "mred-text"
+                                                 #:user? user?
+                                                 #:tethered? tethered?
+                                                 #:console? #t))
            `([relative? . ,(not (or user? tethered?))]
              [subsystem . console]
              [single-instance? . #f]))))))
@@ -54,7 +59,9 @@
         (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]))))))

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

@@ -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 X 10.3*/
+;                                                         actually pointed left until Mac OS 10.3*/
 (define-unicode-key kPencilLeftUnicode #xF802) ;/* Unicode LOWER LEFT PENCIL; 
-;                                                         available in Mac OS X 10.3 and later*/
+;                                                         available in Mac OS 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*/

gui-lib/mred/private/wx/cocoa/queue.rkt

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

gui-lib/mred/private/wx/cocoa/slider.rkt

@@ -164,7 +164,8 @@
     (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 setStringValue: #:type _NSString (format "~a" val))
+    (tellv message-cocoa sizeToFit))
 
   (inherit get-cocoa-window)
   (define/override (post-mouse-down)

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

@@ -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 w h)) (unbox w) (unbox h))])
+            (let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap (max 1 w) (max 1 h))) (unbox w) (unbox h))])
               (internal-set-bitmap bm #t))
             (let ([cr (super get-cr)])
               (set! retained-cr cr)

gui-lib/mred/private/wx/gtk/canvas.rkt

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

gui-lib/mred/private/wx/gtk/cursor.rkt

@@ -36,7 +36,7 @@
                 (cons 'blank void)
                 (cons 'hand GDK_HAND2))))
 
-(define _GdkCursor (_cpointer 'GdkCursor))
+(define _GdkCursor (_cpointer/null '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))

gui-lib/mred/private/wx/gtk/dc.rkt

@@ -4,6 +4,7 @@
          racket/class
          "utils.rkt"
          "types.rkt"
+	 "queue.rkt"
          "window.rkt"
          "frame.rkt"
          "x11.rkt"
@@ -195,9 +196,11 @@
     (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

gui-lib/mred/private/wx/gtk/frame.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require ffi/unsafe
+	 ffi/unsafe/define
          racket/class
          racket/promise
          racket/runtime-path
@@ -16,6 +17,7 @@
          "cursor.rkt"
          "pixbuf.rkt"
 	 "resolution.rkt"
+	 "queue.rkt"
          "../common/queue.rkt")
 
 (provide 
@@ -88,6 +90,10 @@
                               [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))
@@ -107,11 +113,15 @@
   (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 (GdkEventConfigure-width a))
+              (->normal w)
-              (->normal (GdkEventConfigure-height a)))))
+              (->normal h))))
     #f))
 
 (define-cstruct _GdkEventWindowState ([type _int]
@@ -237,6 +247,9 @@
 
     (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)
@@ -264,9 +277,18 @@
     (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)
-                                                       (to-max max-x) (to-max max-y)
+                                                       (+ dx (to-max max-x)) (+ dy (to-max max-y))
                                                        0 0
                                                        (->screen inc-x) (->screen inc-y)
                                                        0.0 0.0

gui-lib/mred/private/wx/gtk/gcwin.rkt

@@ -6,6 +6,7 @@
          "utils.rkt"
          "types.rkt"
          "window.rkt"
+	 "queue.rkt"
          "pixbuf.rkt"
 	 "x11.rkt")
 
@@ -19,7 +20,7 @@
 	      bitmap->gc-bitmap))
 
 ;; Gtk2, only:
-(define-cstruct _GdkWindowAttr
+(define-cstruct _GdkWindowAttr2
   ([title _string]
    [event_mask _int]
    [x _int]
@@ -36,6 +37,29 @@
    [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))
@@ -52,12 +76,19 @@
 
 (define GDK_WINDOW_CHILD 2)
 
-(define-gdk gdk_window_new (_fun _GdkWindow _GdkWindowAttr-pointer _uint -> _GdkWindow))
+(define-gdk gdk_window_new (_fun _GdkWindow
+				 (if gtk3?
+				     _GdkWindowAttr3-pointer
+				     _GdkWindowAttr2-pointer)
+				 _uint -> _GdkWindow))
 
-(define-gdk gdk_window_show _fpointer)
+(define-gdk gdk_window_show-p _fpointer
+  #:c-id gdk_window_show)
 (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)
@@ -69,9 +100,11 @@
 (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
-   [gtk3?
+   [use-x11?
     ; Generate an X11 Pixmap
     (define gwin (widget-window client-gtk))
     (define display (gdk_x11_display_get_xdisplay (gdk_window_get_display gwin)))
@@ -109,7 +142,7 @@
 (define (create-gc-window client-gtk x y w h)
   (define cwin (widget-window client-gtk))
   (cond
-   [gtk3?
+   [use-x11?
     ;; 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))
@@ -132,51 +165,61 @@
 
 (define (free-gc-window win)
   (cond
-   [gtk3? (XDestroyWindow (car win) (cdr win))]
+   [use-x11? (XDestroyWindow (car win) (cdr win))]
    [else (g_object_unref win)]))
 
 (define (make-draw win gc-bitmap w h)
   (cond
-   [gtk3? (vector 'ptr_ptr_ptr->void
+   [use-x11? (vector
+	      (vector 'ptr_ptr_ptr->void
 		      XSetWindowBackgroundPixmap
 		      (car win)
 		      (cdr win)
-		  gc-bitmap)]
+		      gc-bitmap))]
-   [else (vector 'ptr_ptr_ptr_int_int_int_int_int_int_int_int_int->void
+   [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)]))
+		  0 0 0))]))
 
 (define (make-flush)
-  (vector 'ptr_ptr_ptr->void gdk_display_flush (gdk_display_get_default) #f #f))
+  (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))
 
 (define (make-gc-show-desc win gc-bitmap w h)
   (cond
-   [gtk3? (vector
+   [use-x11? (vector*
 	      (make-draw win gc-bitmap w h)
+	      (vector
 	       (vector 'ptr_ptr_ptr->void
 		       XMapRaised
 		       (car win)
 		       (cdr win)
-		   #f)
+		       #f))
 	      (make-flush))]
-   [else  (vector
+   [else  (vector*
-	   (vector 'ptr_ptr_ptr->void gdk_window_show win #f #f)
+	   (vector
+	    (vector 'ptr_ptr_ptr->void gdk_window_show-p win #f #f))
 	   (make-draw win gc-bitmap w h)
 	   (make-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 gtk3?
+    (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))))
+	(vector 'ptr_ptr_ptr->void gdk_window_hide win #f #f)))))

gui-lib/mred/private/wx/gtk/item.rkt

@@ -26,10 +26,14 @@
   (when font
     (let* ([target-size
 	    (cond
-	     [gtk3?
+	     [(and gtk3?
-	      ;; Gtk3 ignores the "size-in-pixels" part of a
+                   ((gtk_get_minor_version) . < . 22))
-	      ;; font spec, so we have to adjust the text size
+	      ;; Prior to version 3.22, GTK+3 ignores the
-	      ;; to compensate.
+	      ;; "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.
 	      (* (send font get-size)
 		 (/ 72.0
 		    (pango_cairo_font_map_get_resolution

gui-lib/mred/private/wx/gtk/panel.rkt

@@ -28,6 +28,7 @@
 (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))
 
@@ -137,7 +138,16 @@
     (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))
-      (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))))
+      (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)))))
 
 (define panel%
   (class (panel-container-mixin (panel-mixin window%))

gui-lib/mred/private/wx/gtk/procs.rkt

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

gui-lib/mred/private/wx/gtk/queue.rkt

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

gui-lib/mred/private/wx/gtk/utils.rkt

@@ -51,6 +51,8 @@
 
               gdk_screen_get_default
 
+              gtk_get_minor_version
+
               ;; for declaring derived structures:
               _GtkObject
 
@@ -200,6 +202,9 @@
 
 (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))])

gui-lib/mred/private/wx/gtk/window.rkt

@@ -55,6 +55,8 @@
               widget-allocation
               widget-parent
 
+	      avoid-preferred-size-warning
+
               the-accelerator-group
               gtk_window_add_accel_group
               gtk_menu_set_accel_group
@@ -102,6 +104,14 @@
 (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))
 
@@ -249,6 +259,9 @@
   (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
@@ -279,11 +292,21 @@
                                [(= 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
-                                 [(positive? dy) 'wheel-down]
+                                  [(>= scroll-accum-y 1)
-                                 [(negative? dy) 'wheel-up]
+                                   (set! scroll-accum-y (sub1 scroll-accum-y))
-                                 [(positive? dx) 'wheel-right]
+                                   'wheel-down]
-                                 [(negative? dx) 'wheel-left]
+                                  [(<= 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])]
                                [else #f]))]
                            [(and (string? im-str)
@@ -614,7 +637,7 @@
           (set! client-delta-h (->normal
 				(- (GtkRequisition-height req)
 				   (GtkRequisition-height creq)))))
-	(when gtk3? (gtk_widget_show gtk))))
+	(when gtk3? (gtk_widget_hide gtk))))
 
     (define/public (set-auto-size [dw 0] [dh 0])
       (let ([req (make-GtkRequisition 0 0)])
@@ -903,7 +926,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 (and transparentish? gtk3?)
+            (unless (or (and transparentish? gtk3?) wayland?)
               (gdk_window_ensure_native win))
             (begin
               (gdk_window_freeze_updates win)

gui-lib/mred/private/wxtop.rkt

@@ -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 X
+                 (super center dir parent-for-center))] ; 2nd argument is for Mac OS
 	
        ;; on-size: ensures that size of frame matches size of content
        ;; input: new-width/new-height: new size of frame

gui-lib/mrlib/syntax-browser.rkt

@@ -1,4 +1,6 @@
 #lang racket/base
+(module+ test (require rackunit))
+
 #|
 
 needed to really make this work:
@@ -11,13 +13,20 @@ needed to really make this work:
            racket/class
            racket/gui/base
            racket/match
-           (prefix-in - racket/base)
+           racket/contract
+           (prefix-in : racket/base)
            "include-bitmap.rkt")
 
   (define orig-output-port (current-output-port))
   (define (oprintf . args) (apply fprintf orig-output-port args))
   
-  (provide render-syntax/snip render-syntax/window snip-class)
+  (provide
+   (contract-out
+    [render-syntax/snip
+     (-> syntax? (is-a?/c snip%))]
+    [render-syntax/window
+     (-> syntax? void?)])
+   snip-class)
   
   ;; this is doing the same thing as the class in
   ;; the framework by the same name, but we don't
@@ -47,7 +56,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%))
@@ -70,8 +79,6 @@ 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%))
@@ -85,67 +92,14 @@ 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]
@@ -444,6 +398,91 @@ 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"))

gui-lib/racket/gui/installer.rkt

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

gui-lib/racket/gui/private/distro-test.rkt

@@ -0,0 +1,28 @@
+#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"))]))

gui-test/framework/tests/README

@@ -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 #|
+- preferences: prefs.rkt  -- now runs directly via raco test
 
   | 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 #|
+  - texts:  text.rkt     -- now runs directly via raco test.
   - pasteboards: |# pasteboard.rkt #|
 
-- keybindings: |# keys.rkt #|
+- keybindings: keys.rkt -- now runs directly via raco test.
 
   | 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 #|
+- group tests: group-test.rkt  -- now runs directly via raco test
 
   | make sure that mred:the-frame-group records frames correctly.
   | fake user input expected.
 
-- number snip: |# number-snip.rkt #|
+- number snip: number-snip.rkt  -- now runs directly via raco test
 
   | some tests for the number-snip% class
 

gui-test/framework/tests/canvas.rkt

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

gui-test/framework/tests/frame.rkt

@@ -1,13 +1,13 @@
 #lang racket/base
 
-(require "private/here-util.rkt"
+(require "private/util.rkt"
          "private/gui.rkt"
          rackunit
          racket/class
          racket/gui/base
          framework)
 
-(define (test-creation name create)
+(define (test-creation name create [verify void])
   (check-true
    (let ()
      (parameterize ([current-eventspace (make-eventspace)])
@@ -20,6 +20,7 @@
           (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)))
@@ -86,6 +87,72 @@
    '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?
@@ -136,19 +203,125 @@
   (test-open "frame:searchable open" frame:searchable%)
   (test-open "frame:text open" frame:text%))
 
-(let ([pref-ht (make-hash)])
+(define (replace-all-tests)
-  (parameterize ([test:use-focus-table #t]
+  (parameterize ([current-eventspace (make-eventspace)])
-                 [preferences:low-level-get-preference
+    (define plain-f
-                  (λ (sym [fail (λ () #f)])
+      (let ()
-                    (hash-ref pref-ht sym fail))]
+        (define c (make-channel))
-                 [preferences:low-level-put-preferences
+        (queue-callback
-                  (λ (syms vals)
+         (λ ()
-                    (for ([sym (in-list syms)]
+           (define f (new frame:searchable% [width 400] [height 400]))
-                          [val (in-list vals)])
+           (send f show #t)
-                      (hash-set! pref-ht sym val)))])
+           (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)))
 

gui-test/framework/tests/group-test.rkt

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

gui-test/framework/tests/keys.rkt

@@ -1,40 +1,24 @@
-#lang racket/base
+#lang racket/gui
+(require framework rackunit "private/util.rkt")
 
-(require "test-suite-utils.rkt")
+(check-equal?
-
+ (let ([k (make-object keymap:aug-keymap%)])
-(module test racket/base)
-  
-  (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)))))
+   (hash-map (send k get-map-function-table) list))
+ '((c:k "abc")))
 
-  (test
+(check-equal?
-   'keymap:aug-keymap%/get-table/ht
+ (let ([k (make-object keymap:aug-keymap%)]
-   (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)))))
+   (hash-map (send k get-map-function-table/ht ht) list))
+ '((c:k "def")))
 
-  (test
+(check-equal?
-   'keymap:aug-keymap%/get-table/chain1
+ (let ([k (make-object keymap:aug-keymap%)]
-   (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)
@@ -43,60 +27,44 @@
    (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)))))
+   (hash-map (send k get-map-function-table) list))
+ '((c:k "abc-k2")))
 
-  (test
+(check-equal?
-   'keymap:aug-keymap%/get-table/chain/2
+ (let ([k (make-object keymap:aug-keymap%)]
-   (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)))))
+   (hash-map (send k get-map-function-table) list))
+ '((c:k "abc-k")))
 
-  (test
+(check-equal?
-   'keymap:aug-keymap%/get-table/normalize-case
+ (let ([k (make-object keymap:aug-keymap%)]
-   (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)))))
+   (hash-map (send k get-map-function-table) list))
+ '((|esc;p| "abc-k2")))
 
-(test
+(check-equal?
- 'keymap:aug-keymap%/all-but-last-bug
+ (let ([k (make-object keymap:aug-keymap%)])
- (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)))))))
+         #:key (lambda (x) (format "~s" x))))
+ '((s:a "shift-ah") (s:m "shift-em")))
 
-(test
+(check-equal?
- 'keymap:aug-keymap%/longer-name
+ (let ()
- (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%))
@@ -108,35 +76,26 @@
    (send k0 chain-to-keymap k2 #t)
    (sort (hash-map (send k0 get-map-function-table) list)
          string<?
-             #:key (lambda (x) (format "~s" x)))))))
+         #:key (lambda (x) (format "~s" x))))
-  
+ '((|c:x;r| "swap if branches")))
-  (define (test-canonicalize name str1 str2)
-    (test
-     (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
-     (lambda (x)
-       (string=? x str2))
-     (lambda ()
-       (queue-sexp-to-mred
-        `(keymap:canonicalize-keybinding-string ,str1)))))
-  
-  (test-canonicalize 1 "c:a" "c:a")
-  (test-canonicalize 2 "d:a" "d:a")
-  (test-canonicalize 3 "m:a" "m:a")
-  (test-canonicalize 4 "a:a" "a:a")
-  (test-canonicalize 5 "s:a" "s:a")
-  (test-canonicalize 6 "c:a" "c:a")
-  (test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
-  (test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
-  (test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
-  (test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
-  (test-canonicalize 11 "esc;s:a" "esc;s:a")
-  (test-canonicalize 12 "s:a;esc" "s:a;esc")
-  (test-canonicalize 13 "ESC;p" "esc;p")
-  (test-canonicalize 14 "?:a:v" "?:a:v")
-  (test-canonicalize 15 "a:?:v" "?:a:v")
-  (test-canonicalize 16 "l:v" "l:v")
-  (test-canonicalize 17 "c:l:v" "c:l:v")
 
+(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")
 
 ;; 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
@@ -411,74 +370,95 @@
                                     (build-buff-spec "||" 1 1)
                                     '(((#\|))))))
 
-  (queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
+(define (queue-callback/wait t)
-  (wait-for-frame "dummy to trick frame group")
+  (define c (make-channel))
+  (queue-callback (λ () (channel-put c (t))))
+  (channel-get c))
 
-  ;; test-key : key-spec -> 
+(define (test-specs frame-name frame-class specs)
-  ;;   evaluates a test case represented as a key-spec
+  (define f #f)
-  (define (test-key key-spec i)
+  (queue-callback/wait
-    (let* ([key-sequences 
+   (λ ()
+     (set! f (make-object frame-class frame-name))
+     (send f show #t)))
+
+  (for ([key-spec (in-list specs)]
+        [i (in-naturals)])
+    (define key-sequences
       ((case (system-type)
          [(macos macosx) key-spec-macos]
          [(unix) key-spec-unix]
          [(windows) key-spec-windows])
-             key-spec)]
+       key-spec))
-           [before (key-spec-before key-spec)]
+    (define before (key-spec-before key-spec))
-           [after (key-spec-after key-spec)]
+    (define after (key-spec-after key-spec))
-           [process-key-sequence
+    (for ([key-sequence (in-list key-sequences)])
-            (lambda (key-sequence)
+      (define text-expect (buff-spec-string after))
-              (let ([text-expect (buff-spec-string after)]
+      (define start-expect (buff-spec-start after))
-                    [start-expect (buff-spec-start after)]
+      (define end-expect (buff-spec-end after))
-                    [end-expect (buff-spec-end after)])
+      (queue-callback
-                (test (list key-sequence i)
+       (λ ()
-                      (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
+         (define frame (test:get-active-top-level-window))
-                      `(let* ([qc (λ (t) (let ([c (make-channel)])
+         (define text (send frame get-editor))
-                                           (queue-callback (λ () (channel-put c (t))))
+         (send text set-overwrite-mode (buff-spec-overwrite? before))
-                                           (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 insert (buff-spec-string before))
-                               (send text set-position ,(buff-spec-start before) ,(buff-spec-end before))))
+         (send text set-position (buff-spec-start before) (buff-spec-end before))
-                         ,@(map (lambda (key) `(test:keystroke ',(car key) ',(cdr key)))
+
-                                key-sequence)
+         (for ([key (in-list key-sequence)])
-                         (qc (λ ()
+           (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))))))))])
+                  (send text get-end-position))))
-      (for-each process-key-sequence key-sequences)))
+       (vector text-expect start-expect end-expect)
+       (~s (list frame-name key-sequence i)))))
+  (queue-callback/wait (λ () (send f close))))
 
+(with-private-prefs
+ (parameterize ([test:use-focus-table #t])
+   ;; needs to be inside the test:use-focus-table setting
+   (parameterize ([current-eventspace (make-eventspace)])
       
-  (define (test-specs frame-name frame-class specs)
+     (define dummy #f)
-    (queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
+     (queue-callback
-    (wait-for-frame frame-name)
+      (λ ()
-    (for ([spec (in-list specs)]
+        (set! dummy (make-object frame:basic% "dummy to trick frame group"))
-          [i (in-naturals)])
+        (send dummy show #t)))
-      (test-key spec i))
-    (queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
 
-(define old-paren-adjusting-prefs
+     (preferences:set 'framework:fixup-open-parens #t)
-  (queue-sexp-to-mred `(list (preferences:get 'framework:fixup-open-parens)
+     (preferences:set 'framework:automatic-parens #f)
-                             (preferences:get 'framework:automatic-parens))))
+     (test-specs "global keybindings test" frame:text% global-specs)
-
+     (test-specs "racket mode keybindings test"
-  
+                 (class frame:editor%
-  (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))
+     (preferences:set 'framework:automatic-parens #t)
-  (test-specs "scheme mode automatic-parens on keybindings test" 
+     (preferences:set 'framework:fixup-open-parens #f)
-              '(class frame:editor%
+     (test-specs "racket mode automatic-parens on keybindings test"
+                 (class frame:editor%
                    (define/override (get-editor%) racket:text%)
                    (super-new))
                  automatic-scheme-specs)
 
-(queue-sexp-to-mred
+     (queue-callback (λ () (send dummy show #f))))))
- `(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))))

gui-test/framework/tests/number-snip.rkt

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

gui-test/framework/tests/prefs.rkt

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

gui-test/framework/tests/private/here-util.rkt

@@ -1,25 +0,0 @@
-#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)))))

gui-test/framework/tests/private/util.rkt

@@ -0,0 +1,51 @@
+#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)))

gui-test/tests/gracket/item.rkt

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