Rackety

flushing to the screen can be starved if flushing is frequently suspend.
changed to
flushing to the screen can be starved if flushing is frequently suspended.

gui-doc/info.rkt

@@ -13,8 +13,10 @@
                      "syntax-color-lib"
                      "wxme-lib"
                      "gui-lib"
+                     "pict-lib"
                      "racket-doc"
-                     "string-constants-doc"))
+                     "string-constants-doc"
+                     "xrepl-doc"))
 (define deps '("base"))
 (define update-implies '("gui-lib"))
 

gui-doc/mrlib/scribblings/interactive-value-port.scrbl

@@ -6,35 +6,53 @@
 @defmodule[mrlib/interactive-value-port]
 
 
-@defproc[(set-interactive-display-handler [port output-port?]) void?]{
+@defproc[(set-interactive-display-handler
+          [port output-port?]
+          [#:snip-handler snip-handler
+           (or/c #f (-> (is-a?/c snip%) output-port? any))
+           #f])
+         void?]{
 
-Sets @racket[port]'s display handler (via
-@racket[port-display-handler]) so that when it encounters these
-values:
+ Sets @racket[port]'s display handler (via
+ @racket[port-display-handler]) so that when it encounters
+ these values:
+ @itemize[@item{syntax objects}
+          @item{snips}]
 
-@itemize[
- 
- @item{exact, real, non-integral numbers}
+ it uses @racket[write-special] to send snips to the port
+ and uses @racketmodname[mrlib/syntax-browser] to turn
+ syntax object into snips and then uses
+ @racket[write-special] with the result to send it to the
+ port. Otherwise, it behaves like the default handler.
 
- @item{syntax objects}
+ If @racket[snip-handler] is not @racket[#f], then
+ @racket[set-interactive-display-handler] passes any snips
+ to it (not those it creates by
+ @racketmodname[mrlib/syntax-browser]) instead of calling 
+ @racket[write-special].
 
-]
-
-it uses @racket[write-special] to send snips to the port,
-instead of those values. Otherwise, it behaves like the
-default handler.
-
-To show values embedded in lists and other compound object, it uses
-@racket[pretty-print].}
+ To show values embedded in lists and other compound object,
+ it uses @racket[pretty-display].
+}
 
 
-@defproc[(set-interactive-write-handler [port output-port?]) void?]{
+@defproc[(set-interactive-write-handler
+          [port output-port?]
+          [#:snip-handler snip-handler
+           (or/c #f (-> (is-a?/c snip%) output-port? any))
+           #f])
+         void?]{
 
 Like @racket[set-interactive-display-handler], but sets the
-@racket[port-write-handler].}
+@racket[port-write-handler] and uses @racket[pretty-write].}
 
 
-@defproc[(set-interactive-print-handler [port output-port?]) void?]{
+@defproc[(set-interactive-print-handler
+          [port output-port?]
+          [#:snip-handler snip-handler
+           (or/c #f (-> (is-a?/c snip%) output-port? any))
+           #f])
+         void?]{
 
 Like @racket[set-interactive-display-handler], but sets the
-@racket[port-print-handler].}
+@racket[port-print-handler] and uses @racket[pretty-print].}

gui-doc/scribblings/framework/editor.scrbl

@@ -454,4 +454,26 @@
   }
 }
 
+@defclass[editor:font-size-message% canvas% ()]{
+ @defconstructor[([message (or/c string? (listof string?))]
+                  [stretchable-height any/c #f])]{
+  The @racket[message] field controls the initial contents. If there
+  is a list of strings, then each string is put on a separate line.
+  If there is just a single string, it is split on newlines and then
+  treated as if it were a list.
+
+  The @racket[stretchable-height] has the opposite default from the
+  @racket[canvas%] superclass.
+ }
+
+ @defmethod[(set-message [message (or/c string? (listof string?))]) void?]{
+  Changes the message.
+
+  If @racket[message]  is a list of strings, then each
+  string is put on a separate line. If there is just a
+  single string, it is split on newlines and then treated as
+  if it were a list argument.
+ }
+}
+
 @(include-previously-extracted "main-extracts.rkt" #rx"^editor:")

gui-doc/scribblings/framework/keymap.scrbl

@@ -19,9 +19,12 @@
 
   @defmethod*[(((get-map-function-table/ht (ht hash?)) hash?))]{
     This is a helper function for @method[keymap:aug-keymap<%>
-    get-map-function-table] that returns the same result, except it accepts a
+    get-map-function-table] that returns a similar result, except it accepts a
     hash-table that it inserts the bindings into. It does not replace any
-    bindings already in @racket[ht].
+    bindings already in @racket[ht]. The result is different from
+    @method[keymap:aug-keymap<%> get-map-function-table] only in that
+    @racket[keymap:aug-keymap<%> get-map-function-table] will remove keybindings
+    that are also have a prefix (since those keybindings are not active).
   }
 }
 @defmixin[keymap:aug-keymap-mixin (keymap%) (keymap:aug-keymap<%>)]{

gui-doc/scribblings/framework/notify.scrbl

@@ -42,6 +42,8 @@ listeners when the contents of the cell is changed.
 @defmethod[(remove-all-listeners) void?]{
   Removes all previously registered callbacks.
 }
+
+@history[#:added "1.18"]{}
 }
 
 @defproc[(notify:notify-box/pref
@@ -67,6 +69,8 @@ reflected in the notify-box.
 (send nb set 'deer)
 (animal)
 ]
+
+@history[#:added "1.18"]{}
 }
 
 @defform[(notify:define-notify name value-expr)
@@ -97,6 +101,8 @@ Useful for aggregating many notify-boxes together into one
   (send food set 'honey))
 (send c get-animal)
 ]
+
+@history[#:added "1.18"]{}
 }
 
 @defproc[(notify:menu-option/notify-box
@@ -108,6 +114,8 @@ Useful for aggregating many notify-boxes together into one
 Creates a @racket[checkable-menu-item%] tied to @racket[notify-box]. The menu item is
 checked whenever @racket[(send notify-box get)] is true. Clicking the
 menu item toggles the value of @racket[notify-box] and invokes its listeners.
+
+@history[#:added "1.18"]{}
 }
 
 @defproc[(notify:check-box/notify-box
@@ -121,6 +129,8 @@ Creates a @racket[check-box%] tied to @racket[notify-box]. The
 check-box is checked whenever @racket[(send notify-box get)] is
 true. Clicking the check box toggles the value of @racket[notify-box]
 and invokes its listeners.
+
+@history[#:added "1.18"]{}
 }
 
 @defproc[(notify:choice/notify-box
@@ -138,6 +148,8 @@ its listeners.
 
 If the value of @racket[notify-box] is not in @racket[choices], either
 initially or upon an update, an error is raised.
+
+@history[#:added "1.18"]{}
 }
 
 @defproc[(notify:menu-group/notify-box
@@ -151,6 +163,8 @@ Returns a list of @racket[checkable-menu-item%] controls tied to
 @racket[(send notify-box get)]. Clicking a menu item updates
 @racket[notify-box] to its label and invokes @racket[notify-box]'s
 listeners.
+
+@history[#:added "1.18"]{}
 }
 
 

gui-doc/scribblings/framework/racket.scrbl

@@ -84,12 +84,22 @@
   }
 
  @defmethod[#:mode public-final
-            (compute-racket-amount-to-indent [pos exact-nonnegative-integer?])
+            (compute-racket-amount-to-indent
+             [pos exact-nonnegative-integer?]
+             [get-head-sexp-type
+              (-> string? (or/c #f 'lambda 'define 'begin 'for/fold 'other))
+              (λ (x) #f)])
             exact-nonnegative-integer?]{
   Computes the amount of space to indent the line containing @racket[pos],
   using the default s-expression indentation strategy.
 
-  @history[#:added "1.9"]
+  The function @racket[get-head-sexp-type] is consulted for each symbol/keyword
+  that follows an open parenthesis. If it returns @racket[#f], then the
+  user's preferences (from the @onscreen{Indenting} panel of the @onscreen{Editing}
+  panel in the preferences dialog) are used.
+
+  @history[#:added "1.9"
+           #:changed "1.26" @list{Added the @racket[get-head-sexp-type] argument.}]
   }
 
  @defmethod[#:mode augment
@@ -248,7 +258,7 @@
   }
 }
 @defmixin[racket:text-mixin
-          (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>)
+          (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>)
           (racket:text<%>)]{
   This mixin adds functionality for editing Racket files.
 

gui-doc/scribblings/framework/splash.scrbl

@@ -74,7 +74,7 @@ that number to control the gauge along the bottom of the splash screen.
   if there is more initialization work to be done where you do not want to count loaded files.
 }
 
-@defproc[(add-splash-icon [bmp (is-a?/c bitmap%)] [x exact-nonnegative-integer?] [y exact-nonnegative-integer?])
+@defproc[(add-splash-icon [bmp (is-a?/c bitmap%)] [x real?] [y real?])
          void?]{
   Adds an icon to the splash screen. (DrRacket uses this function to show the tools as they are loaded.)                
 }

gui-doc/scribblings/framework/text.scrbl

@@ -20,7 +20,7 @@
     This function highlights a region of text in the buffer.
 
     The range between @racket[start] and @racket[end] will be highlighted with
-    the color in color, if the style is @racket['rectangle] (the default).  If
+    the given @racket[color], if the style is @racket['rectangle] (the default).  If
     the style is @racket['ellipse], then an ellipse is drawn around the range
     in the editor, using the color.  If the style is @racket['hollow-ellipse],
     then the outline of an ellipse is drawn around the range in the editor,
@@ -268,6 +268,39 @@
   preference changes.
 }
 
+@definterface[text:ascii-art-enlarge-boxes<%> ()]{
+ @defmethod[(set-ascii-art-enlarge [e? any/c]) void?]{
+  Enables or disables the ascii art box enlarging mode based on @racket[e?]'s true value.
+ }
+ @defmethod[(get-ascii-art-enlarge) boolean?]{
+   Returns @racket[#t] if ascii art box enlarging mode is enabled and @racket[#f] otherwise.
+}
+}
+
+@defmixin[text:ascii-art-enlarge-boxes-mixin (text%) (text:ascii-art-enlarge-boxes<%>)]{
+ @defmethod[#:mode override (on-local-char [event (is-a?/c key-event%)]) void?]{
+  When the @method[key-event% get-key-code] method of @racket[event] returns either
+  @racket['numpad-enter] or @racket[#\return] and
+  @method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
+  @racket[#t], this method handles
+  the return key by adding an additional line in the containing unicode ascii art
+  box and moving the insertion point to the first character on the new line that
+  is in the containing cell.
+
+  It does not call the @racket[super] method (in that case).
+ }
+@defmethod[#:mode override (on-default-char [event (is-a?/c key-event%)]) void?]{
+  When the @method[key-event% get-key-code] method of @racket[event] returns either
+  a character or symbol that corresponds to the insertion of a single character
+  @method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
+  @racket[#t], this method first makes room in the box and then calls the
+  @racket[super] method. If the @method[text% get-overwrite-mode] returns
+  @racket[#f], then it always opens up a column in the box. If @method[text% get-overwrite-mode]
+  returns @racket[#t], then it opens up a column only when the character to
+  be inserted would overwrite one of the walls.
+ }
+}
+
 @definterface[text:first-line<%> (text%)]{
 
   Objects implementing this interface, when @method[text:first-line<%>
@@ -539,8 +572,9 @@
     @racket['framework:anchored-search] preference is on.
   }
 
-  @defmethod[(get-search-hit-count) number?]{
-    Returns the number of hits for the search in the buffer, based on the count
+  @defmethod[(get-search-hit-count) (values number? number?)]{
+    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.
   }
 

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

@@ -58,7 +58,9 @@ On Windows and Unix, @racket[filters] determines a set of filters from
  @racket[filters] list contains two strings: a description of the filter
  as seen by the user, and a filter pattern matched against file names.
  Pattern strings can be a simple ``glob'' pattern, or a number of glob
- patterns separated by a @litchar[";"] character.
+ patterns separated by a @litchar[";"] character. These patterns are not
+ 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
  fixed suffix (e.g., two suffixes of @racket["foo"] and @racket["bar"]
@@ -84,7 +86,7 @@ See also @racket[path-dialog%] for a richer interface.
          (or/c (listof path?) #f)]{
 Like
 @racket[get-file], except that the user can select multiple files, and the
- result is either a list of file paths of @racket[#f].
+ result is either a list of file paths or @racket[#f].
 
 }
 
@@ -118,11 +120,11 @@ If @racket[directory] is not @racket[#f], it is used as the starting
  prefix.
 
 On Windows, if @racket[extension] is not @racket[#f], the returned path
- will get a default extension if the user does not supply one. If
- @racket[extension] is the empty string, then the extension is derived
+ will get a default extension if the user does not supply one. The extension is derived
  from the user's @racket[filters] choice if the corresponding pattern is
- of the form @racket[(string-append "*." extension)]; if the pattern is
- @racket["*.*"], then no default extension is added. Finally, if
+ of the form @racket[(string-append "*." _an-extension)], and the first such
+ pattern is used if the choice has multiple patterns. If the user's choice has the pattern
+ @racket["*.*"] and @racket[extension] is the empty string, then no default extension is added. Finally, if
  @racket[extension] is any string other than the empty string,
  @racket[extension] is used as the default extension when the user's
  @racket[filters] choice has the pattern @racket["*.*"].  Meanwhile, the

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

@@ -183,6 +183,17 @@ Returns a line count installed with @method[editor-canvas%
 
 }
 
+@defmethod[(get-scroll-via-copy) boolean?]{
+  Returns @racket[#t] if scrolling triggers a copy of
+  the editor content (and then a refresh of the newly exposed
+  content). Returns @racket[#f] when scrolling triggers a
+  refresh of the entire editor canvas. Defaults to
+  @racket[#f].
+
+  See also @method[editor<%> on-scroll-to]
+  and @method[editor<%> after-scroll-to].
+}
+
 @defmethod*[([(horizontal-inset)
               (integer-in 1 10000)]
              [(horizontal-inset [step (integer-in 1 10000)])
@@ -324,7 +335,7 @@ Enables or disables bottom-base scrolling, or gets the current enable
 }
 
 
-
+                      
 @defmethod[(set-editor [edit (or/c (or/c (is-a?/c text%) (is-a?/c pasteboard%)) #f)]
                        [redraw? any/c #t])
            void?]{
@@ -360,6 +371,10 @@ If the line count is set to @racket[#f], then the canvas's graphical
 }
 
 
+@defmethod[(set-scroll-via-copy [scroll-via-copy? any/c]) void?]{
+  Changes the scrolling mode refresh. See also @method[editor-canvas% get-scroll-via-copy].
+}
+
 @defmethod*[([(vertical-inset)
               (integer-in 1 10000)]
              [(vertical-inset [step (integer-in 1 10000)])

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

@@ -164,6 +164,20 @@ Does nothing.
 }
 }
 
+ @defmethod[(after-scroll-to) void?]{
+  @methspec{
+   Called when the editor has just scrolled, but the entire display
+   may not have been refreshed. (If the editor scrolls but the entire window
+   is redrawn, this method may not be called.)
+   
+   See also @method[editor-canvas% get-scroll-via-copy].
+  }
+
+  @methimpl{Does nothing.}
+ }
+
+
+                 
 @defmethod*[([(auto-wrap)
               boolean?]
              [(auto-wrap [auto-wrap? any/c])
@@ -857,7 +871,7 @@ If @racket[bottom-right?] is not @racket[#f], the values in the
  @racket[x] and @racket[y] boxes are for the snip's bottom right
  corner instead of its top-left corner.
 
-Obtaining the @techlink{location} if the bottom-right corner may
+Obtaining the @techlink{location} of the bottom-right corner may
  trigger delayed size calculations (including snips other than
  the one whose @techlink{location} was requested).
 
@@ -1656,6 +1670,17 @@ Does nothing.
 
 }}
 
+ @defmethod[(on-scroll-to) void?]{
+  @methspec{
+   Called when the editor is about to scroll, but the entire display is
+   may not be refreshed. (If the editor scrolls but the entire window
+   is redrawn, this method may not be called.)
+   
+   See also @method[editor-canvas% get-scroll-via-copy].
+  }
+
+  @methimpl{Does nothing.}
+ }
 
 @defmethod[#:mode pubment 
            (on-snip-modified [snip (is-a?/c snip%)]
@@ -2446,7 +2471,8 @@ See @xmethod[style-list% notify-on-change] for more information.
            void?]{
 
 Undoes the last editor change, if undos have been enabled by calling
- @method[editor<%> set-max-undo-history] with a non-zero integer.
+ @method[editor<%> set-max-undo-history] with a non-zero integer or
+ @racket['forever].
 
 If the editor is currently performing an undo or redo, the method call
  is ignored.
@@ -2462,7 +2488,7 @@ The system may perform an undo without calling this method in response
  to other method calls. Use methods such as
  @method[editor<%> on-change] to monitor editor content changes.
 
-See also @method[editor<%> add-undo] .
+See also @method[editor<%> add-undo].
 
 }
 

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

@@ -124,6 +124,24 @@ If no argument is provided, the result is @racket[#t] if Option is
  currently treated specially, @racket[#f] otherwise.
 }
 
+@defproc*[([(any-control+alt-is-altgr [on? any/c])
+            void?]
+           [(any-control+alt-is-altgr)
+            boolean?])]{
+
+Enables or disables the treatment of any Control plus Alt as
+ equivalent to AltGr (Windows), as opposed to treating only a
+ left-hand Control plus a right-hand Alt (for keyboard configurations
+ that have both) as AltGr.
+ 
+If @racket[on?] is provided as @racket[#f], key events are reported
+ normally. This setting affects all windows and eventspaces.
+
+If no argument is provided, the result is @racket[#t] if Control plus Alt is
+ currently treated as AltGr, @racket[#f] otherwise.
+
+@history[#:added "1.24"]}
+
 @defproc[(queue-callback [callback (-> any)]
                          [high-priority? any/c #t])
          void?]{

gui-doc/scribblings/gui/gui.scrbl

@@ -52,6 +52,7 @@ Both parts of the toolbox rely extensively on the
 @include-section["prefs.scrbl"]
 @include-section["dynamic.scrbl"]
 @include-section["startup.scrbl"]
+@include-section["init.scrbl"]
 @include-section["libs.scrbl"]
 
 @;------------------------------------------------------------------------

gui-doc/scribblings/gui/init.scrbl

@@ -0,0 +1,30 @@
+#lang scribble/doc
+@(require "common.rkt"
+          (for-label racket/gui/dynamic racket/pretty racket/gui/base setup/dirs))
+
+@title{Init Libraries}
+
+@defmodule*/no-declare[(racket/gui/init)]{The
+@racketmodname[racket/gui/init] library is the default start-up
+library for GRacket. It re-exports the @racketmodname[racket/init] and
+@racketmodname[racket/gui/base] libraries, and it sets
+@racket[current-load] to use @racket[text-editor-load-handler].}
+
+@defmodule*/no-declare[(racket/gui/interactive)]{
+ Similar to @racketmodname[racket/interactive], but for
+ GRacket. This library can be changed by modifying 
+ @racket['gui-interactive-file] in the
+ @filepath{config.rktd} file in @racket[(find-config-dir)].
+ Additionally, if the file @filepath{gui-interactive.rkt}
+ exists in @racket[(find-system-path 'addon-dir)], it is run
+ rather than the installation wide graphical interactive
+ module.
+
+ This library runs the 
+ @racket[(find-graphical-system-path 'init-file)] file in
+ the users home directory if it exists, rather than their 
+ @racket[(find-system-path 'init-file)]. Unlike 
+ @racketmodname[racket/interactive], this library does not
+ start @racketmodname[xrepl].
+
+ @history[#:added "1.27"]}

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

@@ -74,9 +74,11 @@ On Mac OS X, if a Control-key press is combined with a mouse button
            boolean?]{
 
 Returns @racket[#t] if a Control plus Meta event should be treated as
-an AltGr event on Windows: the Control key was the left one and the
-Alt key was the right one (typed that way on a keyboard with a right
-Alt key, or produced by a single AltGr key).
+an AltGr event on Windows. By default, AltGr treatment applies if the
+Control key was the left one and the Alt key (as Meta) was the right one---typed
+that way on a keyboard with a right Alt key, or produced by a single
+AltGr key. See also @racket[any-control+alt-is-altgr], which controls
+whether other Control plus Alt combinations are treated as AltGr.
 
 @history[#:added "1.2"]}
 
@@ -357,11 +359,11 @@ On Mac OS X, if a control-key press is combined with a mouse button
 
 }
 
-@defmethod[(control+meta-is-altgr [down? any/c])
+@defmethod[(set-control+meta-is-altgr [down? any/c])
            void?]{
 
 Sets whether a Control plus Meta combination on Windows should be
-treated as an AltGr combinations. See @racket[get-control+meta-is-altgr].
+treated as an AltGr combinations. See @method[key-event% get-control+meta-is-altgr].
 
 @history[#:added "1.2"]}
 

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

@@ -101,9 +101,13 @@ If @racket[try-chain?] is not @racket[#f], keymaps chained to this one
            void?]{
 
 Chains @racket[next] off @this-obj[] The @racket[next] keymap will be
- used to handle events which are not handled by @this-obj[]. If
- @racket[prefix?] is a true value, then @racket[next] will take
- precedence over other keymaps already chained to @this-obj[].
+ used to handle events which are not handled by @this-obj[].
+
+If @racket[prefix?] is a true value, then @racket[next] will take
+ precedence over other keymaps already chained to @this-obj[] in the
+ case that both keymaps map the same key sequence.
+ When one chained keymap maps a key that is a prefix of another, then the
+ shorter key sequence is always used, regardless of @racket[prefix?].
 
 Multiple keymaps can be chained off one keymap using @method[keymap%
  chain-to-keymap]. When keymaps are chained off a main keymap, events
@@ -187,7 +191,7 @@ The modifier identifiers are:
  @item{@litchar{l:} --- All platforms: Caps Lock}
 
  @item{@litchar{g:} --- Windows: Control plus Alt as AltGr;
-                        see @xmethod[key-event% control+meta-is-altgr]}
+                        see @xmethod[key-event% get-control+meta-is-altgr]}
 
  @item{@litchar{?:} --- All platforms: allow match to character produced by opposite 
                   use of Shift, AltGr/Option, and/or Caps Lock, when available; see

gui-doc/scribblings/gui/libs.scrbl

@@ -19,5 +19,5 @@ either case:
  @item{@filepath{libgtk-3.0[.0]} (GTK+ 3) or @filepath{libgtk-x11-2.0[.0]} (GTK+ 2)}
  @item{@filepath{libgio-2.0[.0]} --- optional, for detecting interface scaling}
  @item{@filepath{libGL[.1]} --- optional, for OpenGL support}
- @item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support}
+ @item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support (GTK+ 2)}
 ]

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

@@ -322,26 +322,31 @@ Plays a sound file. If @racket[async?] is false, the function does not
  The result is @racket[#t] if the sound plays successfully, @racket[#f]
  otherwise.
 
-On Windows, only @filepath{.wav} files are supported.
+On Windows, MCI is used to play sounds, so file formats such as
+ @filepath{.wav} and @filepath{.mp3} should be supported.
 
-On Unix, the function invokes an external sound-playing program;
-  looking for a few known programs (@exec{aplay}, @exec{play},
-  @exec{esdplay}, @exec{sndfile-play}, @exec{audioplay}). In addition, a
+On Mac OS X, Quicktime is used to play sounds; most sound
+ formats (@filepath{.wav}, @filepath{.aiff}, @filepath{.mp3}) are supported in recent versions of
+ Quicktime. To play @filepath{.wav} files, Quicktime 3.0 (compatible
+ with OS 7.5 and up) is required.
+
+On Unix, the function invokes an external sound-playing program---looking
+  by default for a few known programs (@exec{aplay}, @exec{play},
+  @exec{esdplay}, @exec{sndfile-play}, @exec{audioplay}). A
   play command can be defined through the @ResourceFirst{playcmd}
   preference (see @|mrprefsdiscuss|). The preference can hold a
   program name, or a format string containing a single @litchar{~a}
   where the filename should be substituted---and used as a shell
   command.  (Don't use @litchar{~s}, since the string that is used
   with the format string will be properly quoted and wrapped in double
-  quotes.)  A plain command name is usually better since execution is
+  quotes.)  A plain command name is usually better, since execution is
   faster.  The command's output is discarded, unless it returns an
-  error code---in this case the last part of the error output is
+  error code, in which case the last part of the error output is
   shown.
 
-On Mac OS X, Quicktime is used to play sounds; most sound
- formats (.wav, .aiff, .mp3) are supported in recent versions of
- Quicktime. In order to play .wav files, Quicktime 3.0 (compatible
- with OS 7.5 and up) is required.}
+@history[#:changed "1.22" @elem{On Windows, added support for multiple
+                                sounds at once and file format such as
+                                @filepath{.mp3}.}]}
 
 
 @defproc[(position-integer? [v any/c]) boolean?]{

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

@@ -24,8 +24,8 @@ A @racket[panel%] object has a degenerate placement strategy for
 @defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
                                (is-a?/c panel%) (is-a?/c pane%))]
                  [style (listof (or/c 'border 'deleted
-                                      'hscroll 'auto-hscroll
-                                      'vscroll 'auto-vscroll)) null]
+                                      'hscroll 'auto-hscroll 'hide-hscroll
+                                      'vscroll 'auto-vscroll 'hide-vscroll)) null]
                  [enabled any/c #t]
                  [vert-margin spacing-integer? 0]
                  [horiz-margin spacing-integer? 0]
@@ -47,14 +47,17 @@ If the @racket['hscroll] or @racket['vscroll] style is specified, then
  the panel includes a scrollbar in the corresponding direction, and
  the panel's own size in the corresponding direction is not
  constrained by the size of its children subareas. The @racket['auto-hscroll]
- and @racket['auto-vscroll] styles are like @racket['hscroll] or
- @racket['vscroll], but they cause the corresponding scrollbar to
+ and @racket['auto-vscroll] styles imply @racket['hscroll] and
+ @racket['vscroll], respectively, but they cause the corresponding scrollbar to
  disappear when no scrolling is needed in the corresponding direction;
  the @racket['auto-vscroll] and @racket['auto-hscroll] modes assume that
  children subareas are placed using the default algorithm for a @racket[panel%],
- @racket[vertical-panel%], or @racket[horizontal-panel%].
+ @racket[vertical-panel%], or @racket[horizontal-panel%]. The @racket['hide-hscroll]
+ and @racket['hide-vscroll] styles imply @racket['auto-hscroll] and
+ @racket['auto-vscroll], respectively, but the corresponding scroll bar is never
+ made visible (while still allowing the panel content to exceed its own size).
 
 @WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
 
-}}
+@history[#:changed "1.25" @elem{Added @racket['hide-vscroll] and @racket['hide-hscroll].}]}}
 

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

@@ -312,6 +312,12 @@ following symbols:
        not have the keyboard focus (see also
        @method[snip% on-goodbye-event])}
 
+ @item{@indexed-racket['handles-between-events] --- this snip handles
+       mouse events that are between items in the snip
+       (instead of defaulting to treating mouse clicks as
+        setting the position or other event handling that happens
+        at the @racket[text%] or @racket[pasteboard%] level)}
+
  @item{@indexed-racket['width-depends-on-x] --- this snip's display
        width depends on the snip's x-@techlink{location} within the
        editor; e.g.: tab}

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

@@ -0,0 +1,65 @@
+#lang racket/base
+(require racket/class
+         racket/snip
+         racket/format)
+
+(provide circle-snip%
+         (rename-out [circle-snip-class snip-class]))
+
+(define circle-snip%
+  (class snip%
+    (inherit set-snipclass
+             get-flags set-flags
+             get-admin)
+    (init-field [size 20.0])
+    
+    (super-new)
+    (set-snipclass circle-snip-class)
+    (send (get-the-snip-class-list) add circle-snip-class)
+    (set-flags (cons 'handles-events (get-flags)))
+    
+    (define/override (get-extent dc x y	 	 	 	 
+                                 [w #f]
+                                 [h #f]
+                                 [descent #f]
+                                 [space #f]
+                                 [lspace #f]
+                                 [rspace #f])
+      (define (maybe-set-box! b v) (when b (set-box! b v)))
+      (maybe-set-box! w (+ 2.0 size))
+      (maybe-set-box! h (+ 2.0 size))
+      (maybe-set-box! descent 1.0)
+      (maybe-set-box! space 1.0)
+      (maybe-set-box! lspace 1.0)
+      (maybe-set-box! rspace 1.0))
+    
+    (define/override (draw dc x y left top right bottom dx dy draw-caret)
+      (send dc draw-ellipse (+ x 1.0) (+ y 1.0) size size))
+    
+    (define/override (copy)
+      (new circle-snip% [size size]))
+    
+    (define/override (write f)
+      (send f put size))
+    
+    (define/override (on-event dc x y editorx editory e)
+      (when (send e button-down?)
+        (set! size (+ 1.0 size))
+        (define admin (get-admin))
+        (when admin
+          (send admin resized this #t))))))
+
+(define circle-snip-class%
+  (class snip-class%
+    (inherit set-classname)
+    
+    (super-new)
+    (set-classname (~s '((lib "main.rkt" "circle-snip")
+                         (lib "wxme-circle-snip.rkt" "circle-snip"))))
+    
+    (define/override (read f)
+      (define size-b (box 0.0))
+      (send f get size-b)
+      (new circle-snip% [size (unbox size-b)]))))
+
+(define circle-snip-class (new circle-snip-class%))

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

@@ -1,5 +1,8 @@
 #lang scribble/doc
-@(require scribble/bnf "common.rkt")
+@(require scribble/bnf
+          racket/runtime-path
+          (for-label wxme)
+          "common.rkt")
 
 @title[#:tag "snip-example"]{Implementing New Snips}
 
@@ -96,71 +99,25 @@ circle. Clicking on the snip causes the circle to grow. To enable
 copying an instance of the snip from one program/eventspace to
 another, the module should be @filepath{main.rkt} a
 @filepath{circle-snip} directory that is installed as a
-@filepath{circle-snip} package.
+@filepath{circle-snip} package. The snip also has a @racketmodname[wxme]
+reader implementation following it that must be installed as
+the file @filepath{wxme-circle-snip.rkt} in the @filepath{circle-snip}
+directory.
 
-@codeblock{
-#lang racket/base
-(require racket/class
-         racket/snip
-         racket/format)
+@(begin
+   (define-runtime-path snip-example.rkt "snip-example.rkt")
+   (define-runtime-path wxme-circle-snip.rkt "wxme-circle-snip.rkt")
+   (define (put-code filename)
+     (apply
+      typeset-code
+      #:context #'here
+      (call-with-input-file filename
+        (λ (port)
+          (for/list ([l (in-lines port)])
+            (format "~a\n" l))))))
+   (put-code snip-example.rkt))
 
-(provide circle-snip%
-         (rename-out [circle-snip-class snip-class]))
+This is the @filepath{wxme-circle-snip.rkt} file:
 
-(define circle-snip%
-  (class snip%
-    (inherit set-snipclass
-             get-flags set-flags
-             get-admin)
-    (init-field [size 20.0])
+@(put-code wxme-circle-snip.rkt))
 
-    (super-new)
-    (set-snipclass circle-snip-class)
-    (send (get-the-snip-class-list) add circle-snip-class)
-    (set-flags (cons 'handles-events (get-flags)))
-    
-    (define/override (get-extent dc x y	 	 	 	 
-                                 [w #f]
-                                 [h #f]
-                                 [descent #f]
-                                 [space #f]
-                                 [lspace #f]
-                                 [rspace #f])
-      (define (maybe-set-box! b v) (when b (set-box! b v)))
-      (maybe-set-box! w (+ 2.0 size))
-      (maybe-set-box! h (+ 2.0 size))
-      (maybe-set-box! descent 1.0)
-      (maybe-set-box! space 1.0)
-      (maybe-set-box! lspace 1.0)
-      (maybe-set-box! rspace 1.0))
-
-    (define/override (draw dc x y left top right bottom dx dy draw-caret)
-      (send dc draw-ellipse (+ x 1.0) (+ y 1.0) size size))
-
-    (define/override (copy)
-      (new circle-snip% [size size]))
-
-    (define/override (write f)
-      (send f put size))
-
-    (define/override (on-event dc x y editorx editory e)
-      (when (send e button-down?)
-        (set! size (+ 1.0 size))
-        (define admin (get-admin))
-        (when admin
-          (send admin resized this #t))))))
-
-(define circle-snip-class%
-  (class snip-class%
-    (inherit set-classname)
-
-    (super-new)
-    (set-classname (~s '(lib "main.rkt" "circle-snip")))
-
-    (define/override (read f)
-      (define size-b (box 0.0))
-      (send f get size-b)
-      (new circle-snip% [size (unbox size-b)]))))
-
-(define circle-snip-class (new circle-snip-class%))
-}

gui-doc/scribblings/gui/test-snip-example.rkt

@@ -0,0 +1,97 @@
+#lang racket/base
+(require wxme ;; this is dynamically required
+         racket/gui/base
+         racket/file
+         racket/runtime-path
+         racket/port)
+(define collection-name "circle-snip")
+(define snip-example-name "main.rkt")
+(define-runtime-path snip-example.rkt "snip-example.rkt")
+(define-runtime-path wxme-circle-snip.rkt "wxme-circle-snip.rkt")
+(define new-lib-coll-dir
+  (make-temporary-file "scribblings-gui-test-snip-example-~a"
+                       'directory))
+(dynamic-wind
+ void
+ (λ ()
+   (make-directory (build-path new-lib-coll-dir collection-name))
+   (copy-file snip-example.rkt
+              (build-path new-lib-coll-dir collection-name snip-example-name))
+   (copy-file wxme-circle-snip.rkt
+              (build-path new-lib-coll-dir collection-name "wxme-circle-snip.rkt"))
+   
+   
+   (define orig-namespace (current-namespace))
+   (parameterize ([current-library-collection-paths
+                   (cons new-lib-coll-dir
+                         (current-library-collection-paths))])
+     (define save-filename (build-path new-lib-coll-dir collection-name "circle.rkt"))
+     (define circle-snip-pos #f)
+     (define (get-circle-snip-pos) circle-snip-pos)
+     (define (set-circle-snip-pos p) (set! circle-snip-pos p))
+     (parameterize ([current-namespace (make-base-namespace)])
+       (namespace-attach-module orig-namespace 'mred/mred)
+       (define circle-snip% (dynamic-require `(lib ,snip-example-name ,collection-name)
+                                             'circle-snip%))
+       (eval '(require racket/gui/base racket/class racket/format))
+       (eval
+        `(let ()
+           (define circle-snip% ,circle-snip%)
+           (define t (new text%))
+           (send t insert "#lang racket/base\n")
+           (send t insert "(define s ")
+           (,set-circle-snip-pos (send t last-position))
+           (send t insert (new circle-snip%))
+           (send t insert ")\n")
+           (send t insert (~s `(provide s)))
+           (send t save-file ,save-filename)
+           (send t set-filename #f)
+           (define t2 (new text%))
+           (send t2 set-filename ,save-filename)
+           (send t2 load-file)
+           (define circle-snip-copy (send t find-snip (,get-circle-snip-pos) 'after))
+           (unless (is-a? circle-snip-copy circle-snip%)
+             (error 'test-snip-example.rtk "didnt find circle snip.1, found ~s"
+                    circle-snip-copy))
+           (define gui-loaded (dynamic-require ,save-filename 's))
+           (unless (is-a? gui-loaded circle-snip%)
+             (error 'test-snip-example.rkt "didnt find circle snip.2, found ~s"
+                    gui-loaded)))))
+     
+     (parameterize ([current-namespace (make-base-namespace)])
+       (namespace-attach-module orig-namespace 'mred/mred)
+       (define loaded (format "~s" (dynamic-require save-filename 's)))
+       (unless (regexp-match #rx"struct:object:circle-snip%" loaded)
+         (error 'test-snip-example.rkt "didn't find circle snip.3, found ~s" loaded)))
+
+     (define wxme-text-content
+       (parameterize ([current-namespace (make-base-namespace)])
+         (eval '(require racket/base wxme))
+         (eval
+          `(call-with-input-file ,save-filename
+             (λ (port)
+               (apply
+                string
+                (for/list ([s (in-input-port-chars (wxme-port->text-port port))])
+                  s)))))))
+     (unless (regexp-match #rx"[(]circle [0-9.]+[)]" wxme-text-content)
+       (error 'test-snip-example.rkt "didn't find circle snip.4 ~s" wxme-text-content))
+
+     (define wxme-content-as-pos
+       (parameterize ([current-namespace (make-base-namespace)])
+         (eval '(require racket/base wxme))
+         (eval
+          `(call-with-input-file ,save-filename
+             (λ (port)
+               (port-count-lines! port)
+               (for/or ([s (in-port read-char-or-special
+                                    (wxme-port->port port))])
+                 (and (syntax? s)
+                      (list (syntax-position s)))))))))
+     (unless (equal? (list (+ circle-snip-pos 1)) wxme-content-as-pos)
+       (error 'test-snip-example.rkt "didn't find circle snip.5 ~s vs ~s"
+              wxme-content-as-pos
+              circle-snip-pos))))
+ 
+ (λ ()
+   (delete-directory/files new-lib-coll-dir)))

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

@@ -850,13 +850,13 @@ Returns the ending @techlink{position} of the current selection. See
 @defmethod[(get-extend-start-position) exact-nonnegative-integer?]{
   Returns the beginning of the ``extend'' region if the selection
   is currently being extended via, e.g., shift and a cursor movement key; 
-  otherwise returns the same value as @method[text% get-end-position].
+  otherwise returns the same value as @method[text% get-start-position].
 }
 
 @defmethod[(get-extend-end-position) exact-nonnegative-integer?]{
   Returns the beginning of the ``extend'' region if the selection
   is currently being extended via, e.g., shift and a cursor movement key; 
-  otherwise returns the same value as @method[text% get-start-position].
+  otherwise returns the same value as @method[text% get-end-position].
 }
 
 @defmethod[(get-file-format)

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

@@ -998,7 +998,7 @@ animation frame with @method[canvas<%> suspend-flush] and
 are not flushed to the screen. Use @method[canvas<%> flush] to ensure
 that canvas content is flushed when it is ready if a @method[canvas<%>
 suspend-flush] will soon follow, because the process of flushing to
-the screen can be starved if flushing is frequently suspend.  The
+the screen can be starved if flushing is frequently suspended.  The
 method @xmethod[canvas% refresh-now] conveniently encapsulates this
 sequence.
 

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

@@ -65,7 +65,9 @@ If @racket[enable?] is true, the window is enabled, otherwise it is
 @index['("keyboard focus" "setting")]{Moves} the keyboard focus to the
  window, relative to its top-level window, if the window ever accepts
  the keyboard focus.  If the focus is in the window's top-level
- window, then the focus is immediately moved to this
+ window or if the window's top-level window is visible and floating
+ (i.e., created with the @racket['float] style), then the focus is
+ immediately moved to this
  window. Otherwise, the focus is not immediately moved, but when the
  window's top-level window gets the keyboard focus, the focus is
  delegated to this window.

gui-doc/scribblings/gui/wxme-circle-snip.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+(require racket/class
+         racket/format
+         wxme
+         pict)
+
+(provide reader)
+
+(define circle-reader%
+  (class* object% (snip-reader<%>)
+    (define/public (read-header version stream) (void))
+    (define/public (read-snip text-only? version stream)
+      (define size (send stream read-inexact "circle-snip"))
+      (cond
+        [text-only?
+         (string->bytes/utf-8 (~s `(circle ,size)))]
+        [else
+         (new circle-readable [size size])]))
+    (super-new)))
+
+(define circle-readable
+  (class* object% (readable<%>)
+    (init-field size)
+    (define/public (read-special source line column position)
+      ;; construct a syntax object holding a 3d value that
+      ;; is a circle from the pict library with an appropriate
+      ;; source location
+      (datum->syntax #f
+                     (circle size)
+                     (vector source line column position 1)
+                     #f))
+    (super-new)))
+
+(define reader (new circle-reader%))

gui-doc/scribblings/gui/wxme.scrbl

@@ -107,7 +107,8 @@ contains only alpha-numeric ASCII characters, @litchar{.},
 
 
 @defproc[(string->lib-path [str string?] [gui? any/c])
-         (cons/c 'lib (listof string?))]{
+         (or/c (cons/c 'lib (listof string?))
+               #f)]{
 
 Returns a quoted module path for @racket[str] for either
 @racket[editor<%>] mode when @racket[gui?] is true, or

gui-lib/framework/main.rkt

@@ -183,6 +183,14 @@
   (v)
   @{Recognizes the result of @racket[text:make-snip-special].})
 
+ (proc-doc/names
+  text:send-snip-to-port
+  (-> (is-a?/c snip%) output-port? void?)
+  (snip port)
+  @{Sends @racket[snip] to @racket[port] by using @racket[text:make-snip-special],
+    handling a few special cases for performance and backwards compatibility
+    reasons.})
+
  (proc-doc/names
   number-snip:make-repeating-decimal-snip
   (real? boolean? . -> . (is-a?/c snip%))

gui-lib/framework/preferences.rkt

@@ -58,8 +58,7 @@ the state transitions / contracts are:
 (define (pref-un/marshall-set? pref) (hash-has-key? marshall-unmarshall pref))
 (define (preferences:default-set? pref) (hash-has-key? defaults pref))
 (define (pref-can-init? pref)
-  (and (not snapshot-grabbed?)
-       (not (hash-has-key? preferences pref))))
+  (not (hash-has-key? preferences pref)))
 
 ;; type un/marshall = (make-un/marshall (any -> prinable) (printable -> any))
 (define-struct un/marshall (marshall unmarshall))
@@ -343,9 +342,7 @@ the state transitions / contracts are:
           value))))
   
 (define-struct preferences:snapshot (x))
-(define snapshot-grabbed? #f)
 (define (preferences:get-prefs-snapshot)
-  (set! snapshot-grabbed? #t)
   (make-preferences:snapshot 
    (hash-map defaults 
              (λ (k v) (cons k (copy-pref-value k (preferences:get k)))))))
@@ -374,12 +371,12 @@ the state transitions / contracts are:
   (symbol value)
   @{Sets the preference
     @racket[symbol] to @racket[value]. It should be called when the
-    users requests a change to a preference.
+    user requests a change to a preference.
     
     @racket[preferences:set] immediately writes the preference value to disk.    
     It raises an exception matching
     @racket[exn:unknown-preference?]
-    if the preference's default has not been set.
+    if the preference's default has not been set
     
     See also @racket[preferences:set-default].})
 
@@ -389,7 +386,9 @@ the state transitions / contracts are:
   (pref)
   @{Returns a procedure that when applied to zero arguments retrieves the
     current value of the preference named @racket[pref] and when
-    applied to one argument updates the preference named @racket[pref].})
+    applied to one argument updates the preference named @racket[pref].
+
+    @history[#:added "1.18"]{}})
  
  (proc-doc/names
   preferences:add-callback
@@ -404,7 +403,9 @@ the state transitions / contracts are:
     invoked, removes the callback from this preference.
     
     If @racket[weak?] is true, the preferences system will only hold on to
-    the callback weakly.
+    the callback
+    @tech[#:key "weak references"
+          #:doc '(lib "scribblings/reference/reference.scrbl")]{weakly}.
     
     The callbacks will be called in the order in which they were added.
     
@@ -415,7 +416,8 @@ the state transitions / contracts are:
     
     This function raises an exception matching
     @racket[exn:unknown-preference?]
-    if the preference has not been set.})
+    if the preference default has not been set via
+    @racket[preferences:set-default].})
  (proc-doc/names
   preferences:set-default
   (->* (symbol? any/c (any/c . -> . any))
@@ -433,6 +435,8 @@ the state transitions / contracts are:
     
     This sets the default value of the preference @racket[symbol] to
     @racket[value]. If the user has chosen a different setting,
+    (reflected via a call to @racket[preferences:set], possibly
+    in a different run of your program),
     the user's setting will take precedence over the default value.
     
     The @racket[test] argument is used as a safeguard. That function is
@@ -446,7 +450,11 @@ the state transitions / contracts are:
     expected to be a list of symbols that correspond to old versions
     of the preferences. It defaults to @racket['()]. If @racket[rewrite-aliases]
     is present, it is used to adjust the old values of the preferences
-    when they are present in the saved file.})
+    when they are present in the saved file.
+
+    @history[#:changed "1.23" @list{Allow @racket[preferences:set-default]
+               to be called even after a snapshot has been grabbed.}]
+ })
  
  (proc-doc/names
   preferences:default-set?
@@ -562,7 +570,9 @@ the state transitions / contracts are:
   preferences:restore-prefs-snapshot 
   (-> preferences:snapshot? void?)
   (snapshot)
-  @{Restores the preferences saved in @racket[snapshot].
+  @{Restores the preferences saved in @racket[snapshot], updating
+    all of the preferences values to the ones they had at the time
+    that @racket[preferences:get-prefs-snapshot] was called.
     
     See also @racket[preferences:get-prefs-snapshot].})
  
@@ -570,7 +580,7 @@ the state transitions / contracts are:
   preferences:get-prefs-snapshot 
   (-> preferences:snapshot?)
   ()
-  @{Caches all of the current values of the preferences and returns them.
+  @{Caches all of the current values of the known preferences and returns them.
     For any preference that has marshalling and unmarshalling set
     (see @racket[preferences:set-un/marshall]), the preference value is
     copied by passing it through the marshalling and unmarshalling process.

gui-lib/framework/private/aspell.rkt

@@ -95,6 +95,7 @@
              (define aspell-proc #f)
              (define already-attempted-aspell? #f)
              (define current-dict #f)
+             (define is-actually-aspell? #f)
              
              (define (fire-up-aspell)
                (unless already-attempted-aspell?
@@ -105,6 +106,8 @@
                    (define line (with-handlers ((exn:fail? exn-message))
                                   (read-line (list-ref aspell-proc 0))))
                    (asp-log (format "framework: started speller: ~a" line))
+                   (when (regexp-match? #rx"[Aa]spell" line)
+                     (set! is-actually-aspell? #t))
                    
                    (when (and (string? line)
                               (regexp-match #rx"[Aa]spell" line))
@@ -129,7 +132,12 @@
                (close-output-port (list-ref aspell-proc 1))
                (close-input-port (list-ref aspell-proc 3))
                (proc 'kill)
-               (set! aspell-proc #f))
+               (set! aspell-proc #f)
+               (set! is-actually-aspell? #f))
+
+             (define (is-ascii? l)
+               (for/and ([s (in-string l)])
+                 (<= (char->integer s) 127)))
              
              (let loop ()
                (sync
@@ -147,7 +155,9 @@
                       (sync (channel-put-evt resp-chan resp)
                             nack-evt))
                     (cond
-                      [aspell-proc
+                      [(and aspell-proc
+                            (or is-actually-aspell?
+                                (is-ascii? line)))
                        (define stdout (list-ref aspell-proc 0))
                        (define stdin (list-ref aspell-proc 1))
                        

gui-lib/framework/private/color.rkt

@@ -769,7 +769,8 @@ added get-regions
           (clear-old-locations)
           (set! clear-old-locations void)
           (when (and (preferences:get 'framework:highlight-parens)
-                     (not just-clear?))
+                     (not just-clear?)
+                     (not stopped?))
             (let* ((here (get-start-position)))
               (when (= here (get-end-position))
                 (let ([ls (find-ls here)])

gui-lib/framework/private/editor.rkt

@@ -8,7 +8,9 @@
            "interfaces.rkt"
            mzlib/etc
            mred/mred-sig
-           racket/path)
+           racket/path
+           racket/contract
+           racket/format)
   
   (import mred^
           [prefix autosave: framework:autosave^]
@@ -745,3 +747,81 @@
                 #f))))
          'framework:update-lock-icon))
       (super-new)))
+
+(define font-size-message%
+  (class canvas%
+    (init message
+          [stretchable-height #f])
+    (init-field [text-alignment 'center])
+    (define msgs
+      (cond
+        [(string? message) (regexp-split #rx"\n" message)]
+        [((listof string?) message) message]
+        [else
+         (raise-argument-error 'editor:font-size-message%
+                               (~s '(or/c string? (listof string?)))
+                               message)]))
+    (unless (member text-alignment '(left center right))
+      (raise-argument-error 'editor:font-size-message%
+                            (~s '(or/c 'left 'center 'right))
+                            text-alignment))
+    (inherit refresh get-dc get-client-size popup-menu)
+    (define/public (set-message message)
+      (set! msgs
+            (cond
+              [(string? message) (regexp-split #rx"\n" message)]
+              [((listof string?) message) message]
+              [else
+               (raise-argument-error 'editor:font-size-message%::set-label
+                                     (~s '(or/c string? (listof string?)))
+                                     message)]))
+      (refresh))
+    (define/override (on-paint)
+      (define dc (get-dc))
+      (define-values (cw ch) (get-client-size))
+      (define-values (tot-th tot-tw)
+        (for/fold ([tot-th 0] [tot-tw 0])
+                  ([msg (in-list msgs)])
+          (define-values (tw th td ta) (send dc get-text-extent msg))
+          (values (+ tot-th th) (max tot-tw tw))))
+      (for/fold ([y (- (/ ch 2) (/ tot-th 2))]) ([msg (in-list msgs)])
+        (define-values (tw th td ta) (send dc get-text-extent msg))
+        (define x
+          (case text-alignment
+            [(center) (- (/ cw 2) (/ tw 2))]
+            [(left) 2]
+            [(right) (- cw 2)]))
+        (send dc draw-text msg x y)
+        (+ y th)))
+      (super-new [style '(transparent)][stretchable-height stretchable-height])
+      
+      ;; need object to hold onto this function, so this is
+      ;; intentionally a private field, not a method
+      (define (font-size-changed-callback _ new-prefs)
+        (define new-size (font-size-pref->current-font-size new-prefs))
+        (set-the-height/dc-font new-size)
+        (refresh))
+      (preferences:add-callback
+       'framework:standard-style-list:font-size
+       font-size-changed-callback
+       #t)
+      
+      (define/private (set-the-height/dc-font font-size)
+        (define dc (get-dc))
+        (send dc set-font 
+              (send the-font-list find-or-create-font
+                    font-size
+                    (send normal-control-font get-family)
+                    (send normal-control-font get-style)
+                    (send normal-control-font get-weight)
+                    (send normal-control-font get-underlined)
+                    (send normal-control-font get-smoothing)))
+        (define tot-th
+          (for/sum ([msg (in-list msgs)])
+            (define-values (tw th td ta) (send dc get-text-extent msg))
+            th))
+        (min-height (inexact->exact (ceiling tot-th))))
+      
+      (inherit min-height)
+      (set-the-height/dc-font
+       (get-current-preferred-font-size))))

gui-lib/framework/private/frame.rkt

@@ -1118,6 +1118,29 @@
     
     [define anchor-last-state? #f]
     [define overwrite-last-state? #f]
+
+    (define/private (update-ascii-art-enlarge-msg)
+      (define ascii-art-enlarge-mode?
+        (let ([e (get-info-editor)])
+          (and (is-a? e text:ascii-art-enlarge-boxes<%>)
+               (send e get-ascii-art-enlarge))))
+      (unless (eq? (and (member ascii-art-enlarge-mode-msg (send uncommon-parent get-children)) #t)
+                   ascii-art-enlarge-mode?)
+        (if ascii-art-enlarge-mode?
+            (add-uncommon-child ascii-art-enlarge-mode-msg)
+            (remove-uncommon-child ascii-art-enlarge-mode-msg))))
+
+    ;; this callback is kind of a hack. we know that when the set-ascii-art-enlarge
+    ;; method of text:ascii-art-enlarge<%> is called that it changes the preferences
+    ;; value so we will get called back here; it would be better if we could just
+    ;; have the callback happen directly by overriding that method, but that causes
+    ;; backwards incompatibility problems.
+    (define callback (λ (p v)
+                       (queue-callback
+                        (λ () (update-ascii-art-enlarge-msg))
+                        #f)))
+    (preferences:add-callback 'framework:ascii-art-enlarge callback #t)
+
     
     (field (macro-recording? #f))
     (define/private (update-macro-recording-icon)
@@ -1193,6 +1216,7 @@
     (define/override (update-info)
       (super update-info)
       (update-macro-recording-icon)
+      (update-ascii-art-enlarge-msg)
       (overwrite-status-changed)
       (anchor-status-changed)
       (editor-position-changed)
@@ -1233,6 +1257,11 @@
     
     (send (get-info-panel) change-children
           (λ (l) (cons uncommon-parent (remq uncommon-parent l))))
+    
+    (define ascii-art-enlarge-mode-msg (new message%
+                                            [parent uncommon-parent]
+                                            [label "╠╬╣"]
+                                            [auto-resize #t]))
     (define anchor-message
       (new message%
            [font small-control-font]
@@ -1254,6 +1283,7 @@
     (define/private (add-uncommon-child c)
       (define (child->num c)
         (cond
+          [(eq? c ascii-art-enlarge-mode-msg) -1]
           [(eq? c anchor-message) 0]
           [(eq? c overwrite-message) 1]
           [(eq? c macro-recording-message) 2]))
@@ -2053,10 +2083,13 @@
       (let* ([string (get-text)]
              [top-searching-edit (get-searching-text)])
         (when top-searching-edit
-          (let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
-                                  (if (and focus-snip (is-a? focus-snip editor-snip%))
-                                      (send focus-snip get-editor)
-                                      top-searching-edit))]
+          (let ([searching-edit
+                 (let loop ([txt top-searching-edit])
+                   (define focus-snip (send txt get-focus-snip))
+                   (cond
+                     [(and focus-snip (is-a? focus-snip editor-snip%))
+                      (loop (send focus-snip get-editor))]
+                     [else txt]))]
                 
                 [not-found
                  (λ (found-edit skip-beep?)
@@ -2382,11 +2415,12 @@
     (define/public-final (search-string-changed) (search-parameters-changed))
     (define/private (search-parameters-changed)
       (let ([str (send find-edit get-text)])
-        (send text-to-search set-searching-state
-              (if (equal? str "") #f str)
-              case-sensitive-search?
-              replace-visible?
-              #t)))
+        (when text-to-search
+          (send text-to-search set-searching-state
+                (if (equal? str "") #f str)
+                case-sensitive-search?
+                replace-visible?
+                #t))))
     
     (define/public (search-hidden?) hidden?)
     
@@ -2418,6 +2452,10 @@
         (when focus?
           (send find-edit set-position 0 (send find-edit last-position))
           (send (send find-edit get-canvas) focus))
+        (let ([c (send find-edit get-canvas)])
+          (when (and c (send c get-line-count))
+            ;; try to update the canvas so that the font size is correctly accounted for
+            (send c set-editor (send c get-editor))))
         (send find-edit end-edit-sequence)))
     
     (define/public (unhide-search-and-toggle-focus #:new-search-string-from-selection? [new-search-string-from-selection? #f])

gui-lib/framework/private/gen-standard-menus.rkt

@@ -180,7 +180,12 @@
      `(@defmethod[(,(between->name x) [menu (is-a?/c menu-item%)]) void?]{
          This method is called between the addition of the
          @tt[,(format "~a" (between-before x))] and the @tt[,(format "~a" (between-after x))] menu-item. 
-         Override it to add additional menu items at that point. })]
+         Override it to add additional menu items at that point.
+
+      @unquote[(if (equal? (between-procedure x) 'separator)
+                   `@list{Defaults to creating a @racket[separator-menu-item%].}
+                   "")]
+      })]
     [(an-item? x)
      `(@defmethod[(,(an-item->get-item-name x)) (or/c false/c (is-a?/c menu-item%))]{
          This method returns the @racket[menu-item%] object corresponding

gui-lib/framework/private/handler.rkt

@@ -173,10 +173,23 @@
 
 ;; install-recent-items : (is-a?/c menu%) -> void?
 (define (install-recent-items menu)
+  ;; sometimes, we get here via an on-demand callback
+  ;; and we run out of time during the callback and
+  ;; things go awry with the menu. So, to hack around
+  ;; that problem, lets try to do it twice; once here
+  ;; when we notice that things are wrong, and then once
+  ;; in a later event callback, when we know we won't run
+  ;; afoul of any time limits.
+  (do-install-recent-items menu)
+  (queue-callback (λ () (do-install-recent-items menu)) #f)
+  (void))
+
+(define (do-install-recent-items menu)
   (define recently-opened-files
     (preferences:get
      'framework:recently-opened-files/pos))
-  (define (update-menu-with-new-stuff)
+
+  (unless (menu-items-still-same? recently-opened-files menu)
     (for ([item (send menu get-items)]) (send item delete))
     
     (for ([recent-list-item recently-opened-files])
@@ -188,20 +201,7 @@
     (new menu-item%
          [parent menu]
          [label (string-constant show-recent-items-window-menu-item)]
-         [callback (λ (x y) (show-recent-items-window))]))
-  (unless (menu-items-still-same? recently-opened-files menu)
-
-    ;; sometimes, we get here via an on-demand callback
-    ;; and we run out of time during the callback and
-    ;; things go awry with the menu. So, to hack around
-    ;; that problem, lets try to do it twice; once here
-    ;; when we notice that things are wrong, and then once
-    ;; later, when we know we won't run afoul of any time
-    ;; limits.
-    
-    (queue-callback (λ () (update-menu-with-new-stuff)) #f)
-    (update-menu-with-new-stuff))
-  (void))
+         [callback (λ (x y) (show-recent-items-window))])))
 
 (define (recent-list-item->menu-label recent-list-item)
   (let ([filename (car recent-list-item)])

gui-lib/framework/private/interfaces.rkt

@@ -9,7 +9,8 @@
          frame:basic<%>
          frame:standard-menus<%>
          frame:info<%>
-         frame:text-info<%>)
+         frame:text-info<%>
+         text:ascii-art-enlarge-boxes<%>)
 
 (define editor:basic<%>
   (interface (editor<%>)
@@ -32,6 +33,12 @@
   (interface (editor:basic<%>)
     get-keymaps))
 
+
+(define text:ascii-art-enlarge-boxes<%>
+  (interface ()
+    set-ascii-art-enlarge
+    get-ascii-art-enlarge))
+
 (define text:basic<%>  
   (interface (editor:basic<%> (class->interface text%))
     highlight-range

gui-lib/framework/private/keymap-global.rkt

@@ -6,6 +6,7 @@
          "interfaces.rkt"
          "../preferences.rkt"
          "gen-standard-menus.rkt"
+         "unicode-ascii-art.rkt"
          (only-in srfi/13 string-prefix? string-prefix-length)
          2d/dir-chars
          racket/list)
@@ -708,6 +709,17 @@
             (define start (send txt get-start-position))
             (when (= start (send txt get-end-position))
               (widen-unicode-ascii-art-box txt start)))]
+
+         [heighten-unicode-ascii-art-box
+          (λ (txt evt)
+            (define start (send txt get-start-position))
+            (when (= start (send txt get-end-position))
+              (heighten-unicode-ascii-art-box txt start)))]
+
+         [toggle-unicode-ascii-art-enlarge-mode
+          (λ (txt evt)
+            (when (is-a? txt text:ascii-art-enlarge-boxes<%>)
+              (send txt set-ascii-art-enlarge (not (send txt get-ascii-art-enlarge)))))]
          
          [center-in-unicode-ascii-art-box
           (λ (txt evt)
@@ -740,6 +752,8 @@
         
         (add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
         (add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
+        (add "heighten-unicode-ascii-art-box" heighten-unicode-ascii-art-box)
+        (add "toggle-unicode-ascii-art-enlarge-mode" toggle-unicode-ascii-art-enlarge-mode)
         (add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box)
         (add "shift-focus" (shift-focus values))
         (add "shift-focus-backwards" (shift-focus reverse))
@@ -836,7 +850,9 @@
         
         (map "c:x;r;a" "normalize-unicode-ascii-art-box")
         (map "c:x;r;w" "widen-unicode-ascii-art-box")
+        (map "c:x;r;v" "highten-unicode-ascii-art-box")
         (map "c:x;r;c" "center-in-unicode-ascii-art-box")
+        (map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
         
         (map "~m:c:\\" "TeX compress")
         (map "~c:m:\\" "TeX compress")
@@ -1027,166 +1043,6 @@
         (f click-pos eol start-pos click-pos)
         (f click-pos eol click-pos end-pos))))
 
-
-
-(define (widen-unicode-ascii-art-box t orig-pos)
-  (define start-pos (scan-for-start-pos t orig-pos))
-  (when start-pos 
-    (send t begin-edit-sequence)
-    (define-values (start-x start-y) (pos->xy t orig-pos))
-    (define min-y #f)
-    (define max-y #f)
-    (trace-unicode-ascii-art-box 
-     t start-pos #f 
-     (λ (pos x y i-up? i-dn? i-lt? i-rt?)
-       (when (= x start-x)
-         (unless min-y
-           (set! min-y y)
-           (set! max-y y))
-         (set! min-y (min y min-y))
-         (set! max-y (max y max-y)))))
-    (define to-adjust 0)
-    (for ([y (in-range max-y (- min-y 1) -1)])
-      (define-values (pos char) (xy->pos t start-x y))
-      (when (< pos start-pos)
-        (set! to-adjust (+ to-adjust 1)))
-      (send t insert 
-            (cond
-              [(member char lt-chars) #\═]
-              [else #\space])
-            pos pos))
-    (send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))
-    (send t end-edit-sequence)))
-
-(define (normalize-unicode-ascii-art-box t pos)
-  (define start-pos (scan-for-start-pos t pos))
-  (when start-pos
-    (send t begin-edit-sequence)
-    (trace-unicode-ascii-art-box 
-     t start-pos #f 
-     (λ (pos x y i-up? i-dn? i-lt? i-rt?)
-       (cond
-         [(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
-         [(and i-dn? i-lt? i-rt?)       (set-c t pos "╦")]
-         [(and i-up? i-lt? i-rt?)       (set-c t pos "╩")]
-         [(and i-up? i-dn? i-rt?)       (set-c t pos "╠")]
-         [(and i-up? i-dn? i-lt?)       (set-c t pos "╣")]
-         [(and i-up? i-lt?)             (set-c t pos "╝")]
-         [(and i-up? i-rt?)             (set-c t pos "╚")]
-         [(and i-dn? i-lt?)             (set-c t pos "╗")]
-         [(and i-dn? i-rt?)             (set-c t pos "╔")]
-         [(or i-up? i-dn?)              (set-c t pos "║")]
-         [else                          (set-c t pos "═")])))
-     (send t end-edit-sequence)))
-
-(define (center-in-unicode-ascii-art-box txt insertion-pos)
-  (define (find-something start-pos inc char-p?)
-    (define-values (x y) (pos->xy txt start-pos))
-    (let loop ([pos start-pos])
-      (cond
-        [(char-p? (send txt get-character pos))
-         pos]
-        [else
-         (define new-pos (inc pos))
-         (cond
-           [(<= 0 new-pos (send txt last-position))
-            (define-values (x2 y2) (pos->xy txt new-pos))
-            (cond
-              [(= y2 y)
-               (loop new-pos)]
-              [else #f])]
-           [else #f])])))
-  
-  (define (adjust-space before-space after-space pos)
-    (cond
-      [(< before-space after-space) 
-       (send txt insert (make-string (- after-space before-space) #\space) pos pos)]
-      [(> before-space after-space) 
-       (send txt delete pos (+ pos (- before-space after-space)))]))
-  
-  (define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
-  (define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
-  (when (and left-bar right-bar (< left-bar right-bar))
-    (define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
-    (define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
-    (when (and left-space-edge right-space-edge)
-      (define before-left-space-count (- left-space-edge left-bar 1))
-      (define before-right-space-count (- right-bar right-space-edge 1))
-      (define tot-space (+ before-left-space-count before-right-space-count))
-      (define after-left-space-count (floor (/ tot-space 2)))
-      (define after-right-space-count (ceiling (/ tot-space 2)))
-      (send txt begin-edit-sequence)
-      (adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
-      (adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
-      (send txt end-edit-sequence))))
-
-(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
-  (define visited (make-hash))
-  (let loop ([pos start-pos])
-    (unless (hash-ref visited pos #f)
-      (hash-set! visited pos #t)
-      (define-values (x y) (pos->xy t pos))
-      (define c (send t get-character pos))
-      (define-values (up upc) (xy->pos t x (- y 1)))
-      (define-values (dn dnc) (xy->pos t x (+ y 1)))
-      (define-values (lt ltc) (xy->pos t (- x 1) y))
-      (define-values (rt rtc) (xy->pos t (+ x 1) y))
-      (define (interesting-dir? dir-c dir-chars) 
-        (or (and (not only-double-barred-chars?)
-                 (member dir-c adjustable-chars)
-                 (member c dir-chars))
-            (and (member dir-c double-barred-chars)
-                 (member c double-barred-chars))))
-      (define i-up? (interesting-dir? upc up-chars))
-      (define i-dn? (interesting-dir? dnc dn-chars))
-      (define i-lt? (interesting-dir? ltc lt-chars))
-      (define i-rt? (interesting-dir? rtc rt-chars))
-      (f pos x y i-up? i-dn? i-lt? i-rt?)
-      (when i-up? (loop up))
-      (when i-dn? (loop dn))
-      (when i-lt? (loop lt))
-      (when i-rt? (loop rt)))))
-
-(define (scan-for-start-pos t pos)
-  (define-values (x y) (pos->xy t pos))
-  (findf
-   (λ (p) (adj? t p))
-   (for*/list ([xadj '(0 -1)]
-               [yadj '(0 -1 1)])
-     (define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
-     d)))
-       
-(define (adj? t pos)
-  (and pos 
-       (member (send t get-character pos) 
-               adjustable-chars)))
-
-(define (set-c t pos s)
-  (unless (equal? (string-ref s 0) (send t get-character pos))
-    (send t delete pos (+ pos 1))
-    (send t insert s pos pos)))
-
-(define (pos->xy text pos)
-  (define para (send text position-paragraph pos))
-  (define start (send text paragraph-start-position para))
-  (values (- pos start) para))
-
-(define (xy->pos text x y)
-  (cond
-    [(and (<= 0 x) (<= 0 y (send text last-paragraph)))
-     (define para-start (send text paragraph-start-position y))
-     (define para-end (send text paragraph-end-position y))
-     (define pos (+ para-start x))
-     (define res-pos
-       (and (< pos para-end)
-            ;; the newline at the end of the
-            ;; line is not on the line, so use this guard
-            pos))
-     (if res-pos
-         (values res-pos (send text get-character res-pos))
-         (values #f #f))]
-    [else (values #f #f)]))
-
 (define/contract (run-some-keystrokes before key-evts)
   (-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?)
       (listof (is-a?/c key-event%))
@@ -1204,182 +1060,7 @@
         (send t get-end-position)))
 
 (module+ test
-  (require rackunit 
-           racket/gui/base)
-  (define sa string-append)
-  
-  (define (first-value-xy->pos a b c)
-    (define-values (d e) (xy->pos a b c))
-    d)
-  
-  (let ([t (new text%)])
-    (send t insert (sa "abc\n"
-                       "d\n"
-                       "ghi\n"))
-    (check-equal? (first-value-xy->pos t 0 0) 0)
-    (check-equal? (first-value-xy->pos t 1 0) 1)
-    (check-equal? (first-value-xy->pos t 0 1) 4)
-    (check-equal? (first-value-xy->pos t 3 0) #f)
-    (check-equal? (first-value-xy->pos t 0 3) #f)
-    (check-equal? (first-value-xy->pos t 1 1) #f)
-    (check-equal? (first-value-xy->pos t 2 1) #f)
-    (check-equal? (first-value-xy->pos t 0 2) 6)
-    (check-equal? (first-value-xy->pos t 1 2) 7)
-    (check-equal? (first-value-xy->pos t 2 -1) #f)
-    (check-equal? (first-value-xy->pos t -1 0) #f)
-    (check-equal? (first-value-xy->pos t 2 2) 8)
-    (check-equal? (first-value-xy->pos t 2 3) #f))
-  
-  (let ([t (new text%)])
-    (send t insert (sa "abc\n"
-                       "d\n"
-                       "ghi"))
-    (check-equal? (first-value-xy->pos t 2 2) 8)
-    (check-equal? (first-value-xy->pos t 2 3) #f))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append "+-+\n"
-                                  "| |\n"
-                                  "+-+\n"))
-    (normalize-unicode-ascii-art-box t 0)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔═╗\n"
-                   "║ ║\n"
-                   "╚═╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append "+=+\n"
-                                  "| |\n"
-                                  "+=+\n"))
-    (normalize-unicode-ascii-art-box t 0)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔═╗\n"
-                   "║ ║\n"
-                   "╚═╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append "+-+-+\n"
-                                  "| | |\n"
-                                  "+-+-+\n"
-                                  "| | |\n"
-                                  "+-+-+\n"))
-    (normalize-unicode-ascii-art-box t 0)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔═╦═╗\n"
-                   "║ ║ ║\n"
-                   "╠═╬═╣\n"
-                   "║ ║ ║\n"
-                   "╚═╩═╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append
-                    "╔═══╗\n"
-                    "║ - ║\n"
-                    "╚═══╝\n"))
-    
-    (normalize-unicode-ascii-art-box t 0)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔═══╗\n"
-                   "║ - ║\n"
-                   "╚═══╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append
-                    "╔═╦═╗\n"
-                    "║ ║ ║\n"
-                    "╠═╬═╣\n"
-                    "║ ║ ║\n"
-                    "╚═╩═╝\n"))
-    (send t set-position 1 1)
-    (widen-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-start-position) 2)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔══╦═╗\n"
-                   "║  ║ ║\n"
-                   "╠══╬═╣\n"
-                   "║  ║ ║\n"
-                   "╚══╩═╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append
-                    "╔═╦═╗\n"
-                    "║ ║ ║\n"
-                    "╠═╬═╣\n"
-                    "║ ║ ║\n"
-                    "╚═╩═╝\n"))
-    (send t set-position 8 8)
-    (widen-unicode-ascii-art-box t 8)
-    (check-equal? (send t get-start-position) 10)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔══╦═╗\n"
-                   "║  ║ ║\n"
-                   "╠══╬═╣\n"
-                   "║  ║ ║\n"
-                   "╚══╩═╝\n")))
-  
-  (let ([t (new text%)])
-    (send t insert (string-append
-                    "╔═╦═╗\n"
-                    "║ ║ ║\n"
-                    "╠═╬═╣\n"
-                    "║ ║ ║\n"))
-    (send t set-position 8 8)
-    (widen-unicode-ascii-art-box t 8)
-    (check-equal? (send t get-text)
-                  (string-append
-                   "╔══╦═╗\n"
-                   "║  ║ ║\n"
-                   "╠══╬═╣\n"
-                   "║  ║ ║\n")))
-  
-  (let ([t (new text%)])
-    (send t insert "║ x   ║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║  x  ║\n"))
-  
-  (let ([t (new text%)])
-    (send t insert "║x    ║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║  x  ║\n"))
-  
-  (let ([t (new text%)])
-    (send t insert "║    x║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║  x  ║\n"))
-  
-  (let ([t (new text%)])
-    (send t insert "║abcde║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║abcde║\n"))
-  
-  (let ([t (new text%)])
-    (send t insert "║║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║║\n"))
-  
-  (let ([t (new text%)])
-    (send t insert "║abcde \n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  "║abcde \n"))
-  
-  (let ([t (new text%)])
-    (send t insert " abcde║\n")
-    (center-in-unicode-ascii-art-box t 1)
-    (check-equal? (send t get-text)
-                  " abcde║\n"))
-
+  (require rackunit)
   (check-equal? (run-some-keystrokes '("abc" 0 0)
                                      (list (new key-event% [key-code 'escape])
                                            (new key-event% [key-code #\c])))

gui-lib/framework/private/keymap.rkt

@@ -148,7 +148,38 @@
         (hash-set! function-table (string->symbol keyname) fname))
       
       (define/public (get-map-function-table)
-        (get-map-function-table/ht (make-hasheq)))
+        (define table-possibly-with-prefixes (get-map-function-table/ht (make-hasheq)))
+
+        (define trie (make-hash))
+        (define (add-to-trie loks name)
+          (let loop ([trie trie]
+                     [loks loks])
+            (cond
+              [(null? (cdr loks))
+               (hash-set! trie (car loks) name)]
+              [else
+               (define sub (hash-ref trie (car loks)
+                                     (λ ()
+                                       (define h (make-hash))
+                                       (hash-set! trie (car loks) h)
+                                       h)))
+               (loop sub (cdr loks))])))
+        
+        (for ([(canonicalized-symbol keyname) (in-hash table-possibly-with-prefixes)])
+          (define keys (regexp-split #rx";" (symbol->string canonicalized-symbol)))
+          (add-to-trie keys keyname))
+
+        (define table-without-prefixes (make-hash))
+        (let loop ([trie trie]
+                   [prefix '()])
+          (cond
+            [(string? trie)
+             (define keystring (string->symbol (join-strings ";" (reverse prefix))))
+             (hash-set! table-without-prefixes keystring trie)]
+            [else (for ([(key sub-trie) (in-hash trie)])
+                    (loop sub-trie (cons key prefix)))]))
+
+        table-without-prefixes)
       
       (define/public (get-map-function-table/ht table)
         (for ([(keyname fname) (in-hash function-table)])
@@ -194,7 +225,7 @@
       (define/private (all-but-last l)
         (cond
           [(null? l) l]
-          [(null? (cdr l)) l]
+          [(null? (cdr l)) '()]
           [else (cons (car l) (all-but-last (cdr l)))]))
       
       (super-new)))

gui-lib/framework/private/main.rkt

@@ -25,6 +25,8 @@
 
 (application-preferences-handler (λ () (preferences:show-dialog)))
 
+(preferences:set-default 'framework:ascii-art-enlarge #f boolean?)
+
 (preferences:set-default 'framework:color-scheme 'classic symbol?)
 
 (preferences:set-default 'framework:column-guide-width
@@ -198,7 +200,7 @@
                                          "match-let" "match-let*" "match-letrec"
                                          "letrec"
                                          "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
-                                         "parameterize" "parameterize*"
+                                         "parameterize" "parameterize*" "syntax-parameterize"
                                          "with-syntax" "with-handlers")))
 
 (set-square-bracket-nonum-pref 'framework:square-bracket:for/fold for/folds)
@@ -214,6 +216,10 @@
 (preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v)))
 (map-command-as-meta-key (preferences:get 'framework:special-meta-key))
 
+(preferences:set-default 'framework:any-control+alt-is-altgr #f boolean?)
+(preferences:add-callback 'framework:any-control+alt-is-altgr (λ (p v) (any-control+alt-is-altgr v)))
+(any-control+alt-is-altgr (preferences:get 'framework:any-control+alt-is-altgr))
+
 (preferences:set-default 'framework:fraction-snip-style 
                          'mixed (λ (x) (memq x '(mixed improper decimal))))
 
@@ -441,7 +447,7 @@
                unit/sig unit/lang
                with-handlers
                interface
-               parameterize parameterize*
+               parameterize parameterize* syntax-parameterize
                call-with-input-file call-with-input-file* with-input-from-file
                with-input-from-port call-with-output-file
                with-output-to-file with-output-to-port 
@@ -451,7 +457,7 @@
                type-case))
   (preferences:set-default 
    'framework:tabify
-   (list defaults-ht #rx"^begin" #rx"^def" #rx"^for\\*?(/|$)" #f)
+   (list defaults-ht #rx"^begin" #rx"^def" #rx"^(for\\*?(/|$)|with-)" #f)
    (list/c (hash/c symbol? (or/c 'for/fold 'define 'begin 'lambda) #:flat? #t)
            (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?)))
   

gui-lib/framework/private/preferences.rkt

@@ -51,33 +51,34 @@ the state transitions / contracts are:
   
   (define (get-preference/gui sym [def (λ () (error 'get-preference/gui "unknown pref ~s" sym))])
     (define (try)
-      (get-preference sym
-                      def
-                      #:timeout-lock-there
-                      (λ (filename)
-                        (define what-to-do
-                          (cond
-                            [get-pref-retry-result
-                             get-pref-retry-result]
-                            [else
-                             (define-values (res dont-ask-again?)
-                               (message+check-box/custom
-                                (string-constant error-reading-preferences)
-                                (format (string-constant error-reading-preferences-explanation)
-                                        sym)
-                                (string-constant dont-ask-again-until-drracket-restarted) ;; check label
-                                (string-constant try-again)
-                                (string-constant give-up-and-use-the-default)
-                                #f
-                                #f
-                                '(caution default=1)
-                                1)) ;; cannot return #f here or get-pref-retry-result may get set wrong
-                             (when dont-ask-again?
-                               (set! get-pref-retry-result res))
-                             res]))
-                        (case what-to-do
-                          [(1) (try)]
-                          [(2) (def)]))))
+      (get-preference
+       sym
+       def
+       #:timeout-lock-there
+       (λ (filename)
+         (define what-to-do
+           (cond
+             [get-pref-retry-result
+              get-pref-retry-result]
+             [else
+              (define-values (res dont-ask-again?)
+                (message+check-box/custom
+                 (string-constant error-reading-preferences)
+                 (format (string-constant error-reading-preferences-explanation)
+                         sym)
+                 (string-constant dont-ask-again-until-drracket-restarted) ;; check label
+                 (string-constant try-again)
+                 (string-constant give-up-and-use-the-default)
+                 #f
+                 #f
+                 '(caution default=1)
+                 1)) ;; cannot return #f here or get-pref-retry-result may get set wrong
+              (when dont-ask-again?
+                (set! get-pref-retry-result res))
+              res]))
+         (case what-to-do
+           [(1) (try)]
+           [(2) (def)]))))
     (try))
                           
   
@@ -127,7 +128,9 @@ the state transitions / contracts are:
                #f
                #f ;;parent
                '(default=2 caution))]
-             [else (error 'preferences.rkt "preferences-lock-file-mode returned unknown mode ~s\n" the-mode)]))
+             [else (error 'preferences.rkt
+                          "preferences-lock-file-mode returned unknown mode ~s\n"
+                          the-mode)]))
          (case mb-ans
            [(2 #f) (record-actual-failure)]
            [(1) 
@@ -457,7 +460,8 @@ the state transitions / contracts are:
                  (list (string-constant editor-prefs-panel-label) 
                        (string-constant editor-general-prefs-panel-label))
                  (λ (editor-panel)
-                   (add-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace)
+                   (add-check editor-panel 'framework:delete-forward?
+                              (string-constant map-delete-to-backspace)
                               not not)
                    (add-check editor-panel 
                               'framework:auto-set-wrap?
@@ -474,6 +478,11 @@ the state transitions / contracts are:
                                 'framework:special-meta-key
                                 (string-constant command-as-meta)))
                    
+                   (when (memq (system-type) '(windows))
+                     (add-check editor-panel 
+                                'framework:any-control+alt-is-altgr
+                                (string-constant any-control+alt-is-altgr)))
+                   
                    (add-check editor-panel 
                               'framework:coloring-active
                               (string-constant online-coloring-active))
@@ -498,93 +507,94 @@ the state transitions / contracts are:
                               'framework:line-spacing-add-gap?
                               (string-constant add-spacing-between-lines))
                    
-                   (let ([hp (new horizontal-panel% [parent editor-panel] [stretchable-height #f])]
-                         [init-pref (preferences:get 'framework:column-guide-width)])
-                     (define on-cb
-                       (new check-box% 
-                            [parent hp]
-                            [label (string-constant maximum-char-width-guide-pref-check-box)]
-                            [value (car init-pref)]
-                            [callback
-                             (λ (x y)
-                               (update-pref)
-                               (update-tf-bkg)
-                               (send tf enable (send on-cb get-value)))]))
-                     (define tf 
-                       (new text-field%
-                            [label #f]
-                            [parent hp]
-                            [init-value (format "~a" (cadr init-pref))]
-                            [callback
-                             (λ (x y)
-                               (update-pref)
-                               (update-tf-bkg))]))
-                     (define (update-tf-bkg)
-                       (send tf set-field-background
-                             (send the-color-database find-color 
-                                   (cond
-                                     [(not (send on-cb get-value)) "gray"]
-                                     [(good-val? (string->number (send tf get-value)))
-                                      "white"]
-                                     [else
-                                      "yellow"]))))
-                     (define (good-val? n)
-                       (and (exact-integer? n)
-                            (>= n 2)))
-                     (define (update-pref)
-                       (define current (preferences:get 'framework:column-guide-width))
-                       (define candidate-num (string->number (send tf get-value)))
-                       (preferences:set 'framework:column-guide-width
-                                        (list (send on-cb get-value)
-                                              (if (good-val? candidate-num)
-                                                  candidate-num
-                                                  (cadr current)))))
-                     (update-tf-bkg))
+                   (add-number editor-panel
+                               'framework:column-guide-width
+                               (string-constant maximum-char-width-guide-pref-check-box)
+                               (λ (n) (and (exact-integer? n) (>= n 2))))
                    
                    (editor-panel-procs editor-panel))))])
       (add-editor-checkbox-panel)))
-  
-  (define (add-general-checkbox-panel)
-    (letrec ([add-general-checkbox-panel
-              (λ ()
-                (set! add-general-checkbox-panel void)
-                (add-checkbox-panel 
-                 (list (string-constant general-prefs-panel-label))
-                 (λ (editor-panel)
-                   (make-recent-items-slider editor-panel)
-                   (add-check editor-panel
-                              'framework:autosaving-on? 
-                              (string-constant auto-save-files))
-                   (add-check editor-panel 'framework:backup-files? (string-constant backup-files))
-                   (add-check editor-panel 'framework:show-status-line (string-constant show-status-line))
-                   ;; does this not belong here?
-                   ;; (add-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers)
-                   (add-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one))
-                   (add-check editor-panel 
-                              'framework:display-line-numbers
-                              (string-constant display-line-numbers))
-                   (define print-rb (new radio-box% 
-                                         [label (string-constant printing-mode)]
-                                         [parent editor-panel]
-                                         [choices (list (string-constant print-using-platform-specific-mode)
-                                                        (string-constant print-to-ps)
-                                                        (string-constant print-to-pdf))]
-                                         [callback
-                                          (λ (rb evt)
-                                            (preferences:set 'framework:print-output-mode
-                                                             (case (send print-rb get-selection)
-                                                               [(0) 'standard]
-                                                               [(1) 'postscript]
-                                                               [(2) 'pdf])))]))
-                   (define (update-print-rb what)
-                     (send print-rb set-selection (case what
-                                                    [(standard) 0]
-                                                    [(postscript) 1]
-                                                    [(pdf) 2])))
-                   (update-print-rb (preferences:get 'framework:print-output-mode))
-                   (preferences:add-callback 'framework:print-output-mode (λ (p v) (update-print-rb v)))
-                   (general-panel-procs editor-panel))))])
-      (add-general-checkbox-panel)))
+
+(define (add-number editor-panel pref-name label good-val?)
+  (define hp (new horizontal-panel% [parent editor-panel] [stretchable-height #f]))
+  (define init-pref (preferences:get pref-name))
+  (define on-cb
+    (new check-box% 
+         [parent hp]
+         [label label]
+         [value (car init-pref)]
+         [callback
+          (λ (x y)
+            (update-pref)
+            (update-tf-bkg)
+            (send tf enable (send on-cb get-value)))]))
+  (define tf 
+    (new text-field%
+         [label #f]
+         [parent hp]
+         [init-value (format "~a" (cadr init-pref))]
+         [callback
+          (λ (x y)
+            (update-pref)
+            (update-tf-bkg))]))
+  (define (update-tf-bkg)
+    (send tf set-field-background
+          (send the-color-database find-color 
+                (cond
+                  [(not (send on-cb get-value)) "gray"]
+                  [(good-val? (string->number (send tf get-value)))
+                   "white"]
+                  [else
+                   "yellow"]))))
+  (define (update-pref)
+    (define current (preferences:get pref-name))
+    (define candidate-num (string->number (send tf get-value)))
+    (preferences:set pref-name
+                     (list (send on-cb get-value)
+                           (if (good-val? candidate-num)
+                               candidate-num
+                               (cadr current)))))
+  (update-tf-bkg))
+
+(define (add-general-checkbox-panel) (add-general-checkbox-panel/real))
+(define (add-general-checkbox-panel/real)
+  (set! add-general-checkbox-panel/real void)
+  (add-checkbox-panel 
+   (list (string-constant general-prefs-panel-label))
+   (λ (editor-panel)
+     (make-recent-items-slider editor-panel)
+     (add-check editor-panel
+                'framework:autosaving-on? 
+                (string-constant auto-save-files))
+     (add-check editor-panel 'framework:backup-files? (string-constant backup-files))
+     (add-check editor-panel 'framework:show-status-line (string-constant show-status-line))
+     ;; does this not belong here?
+     ;; (add-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers)
+     (add-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one))
+     (add-check editor-panel 
+                'framework:display-line-numbers
+                (string-constant display-line-numbers))
+     (define print-rb (new radio-box% 
+                           [label (string-constant printing-mode)]
+                           [parent editor-panel]
+                           [choices (list (string-constant print-using-platform-specific-mode)
+                                          (string-constant print-to-ps)
+                                          (string-constant print-to-pdf))]
+                           [callback
+                            (λ (rb evt)
+                              (preferences:set 'framework:print-output-mode
+                                               (case (send print-rb get-selection)
+                                                 [(0) 'standard]
+                                                 [(1) 'postscript]
+                                                 [(2) 'pdf])))]))
+     (define (update-print-rb what)
+       (send print-rb set-selection (case what
+                                      [(standard) 0]
+                                      [(postscript) 1]
+                                      [(pdf) 2])))
+     (update-print-rb (preferences:get 'framework:print-output-mode))
+     (preferences:add-callback 'framework:print-output-mode (λ (p v) (update-print-rb v)))
+     (general-panel-procs editor-panel))))
   
   (define (add-warnings-checkbox-panel)
     (letrec ([add-warnings-checkbox-panel
@@ -639,7 +649,8 @@ the state transitions / contracts are:
                    (cond
                      [(string? default) string?]
                      [(number? default) number?]
-                     [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))])
+                     [else (error 'internal-error.set-default
+                                  "unrecognized default: ~a\n" default)])))))])
       
       (for-each (set-default build-font-entry font-default-string string?)
                 font-families)

gui-lib/framework/private/racket.rkt

@@ -504,12 +504,6 @@
           [else
            (+ i 1)])))
     
-    (public tabify-all insert-return calc-last-para 
-            box-comment-out-selection comment-out-selection uncomment-selection
-            flash-forward-sexp 
-            flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
-            remove-parens-forward)
-    
     (define/public (get-limit pos) 0)
     
     (define/public (balance-parens key-event [smart-skip #f])
@@ -564,11 +558,15 @@
                 tab-char?))
     (define/pubment (compute-amount-to-indent pos)
       (inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos))
-    (define/public-final (compute-racket-amount-to-indent pos)
+    (define/public-final (compute-racket-amount-to-indent pos [_get-head-sexp-type (λ (x) #f)])
       (cond
         [(is-stopped?) #f]
         [else
-         (define tabify-prefs (preferences:get 'framework:tabify))
+         (define get-head-sexp-type
+           (let ([tabify-prefs (preferences:get 'framework:tabify)])
+             (λ (text)
+               (or (_get-head-sexp-type text)
+                   (get-head-sexp-type-from-prefs text tabify-prefs)))))
          (define last-pos (last-position))
          (define para (position-paragraph pos))
          (define is-tabbable?
@@ -625,8 +623,11 @@
            (define id-end (get-forward-sexp contains))
            (and (and id-end (> id-end contains))
                 (let ([text (get-text contains id-end)])
-                  (or (get-keyword-type text tabify-prefs)
-                      'other))))
+                  (cond
+                    [(member (classify-position contains) '(keyword symbol))
+                     (get-head-sexp-type text)]
+                    [else
+                     'other]))))
          (define (procedure-indent)
            (case (get-proc)
              [(begin define) 1]
@@ -690,16 +691,24 @@
               ;; So far, the S-exp containing "pos" was all on
               ;;  one line (possibly not counting the opening paren),
               ;;  so indent to follow the first S-exp's end
-              ;;  unless there are just two sexps and the second is an ellipsis.
-              ;;  in that case, we just ignore the ellipsis
+              ;;  unless
+              ;;    - there are just two sexps earlier and the second is an ellipsis.
+              ;;      in that case, we just ignore the ellipsis or
+              ;;    - the sexp we are indenting is a bunch of hypens;
+              ;;      in that case, we match the opening paren
               (define id-end (get-forward-sexp contains))
               (define name-length
                 (if id-end
                     (- id-end contains)
                     0))
               (cond
+                [(or (first-sexp-is-keyword? contains)
+                     (sexp-is-all-hyphens? contains))
+                 (visual-offset contains)]
                 [(second-sexp-is-ellipsis? contains)
                  (visual-offset contains)]
+                [(sexp-is-all-hyphens? pos)
+                 (visual-offset contains)]
                 [(not (find-up-sexp pos))
                  (visual-offset contains)]
                 [else
@@ -718,6 +727,21 @@
                       (loop next-to-last next-to-last-para)
                       (visual-offset last))))]))
          amt-to-indent]))
+
+    ;; returns #t if `pos` is in a symbol (or keyword) that consists entirely
+    ;; of hyphens and has at least three hyphens; returns #f otherwise
+    (define/private (sexp-is-all-hyphens? pos)
+      (define fst-end (get-forward-sexp pos))
+      (and fst-end
+           (let ([fst-start (get-backward-sexp fst-end)])
+             (and fst-start
+                  (memq (classify-position fst-start) '(symbol keyword))
+                  (>= (- fst-end fst-start) 3)
+                  (let loop ([i fst-start])
+                    (cond
+                      [(< i fst-end)
+                       (and (equal? #\- (get-character i)) (loop (+ i 1)))]
+                      [else #t]))))))
     
     ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
     ;; otherwise, returns #f
@@ -734,12 +758,20 @@
                              (and (or (not thrd-start)
                                       (not (= (position-paragraph thrd-start)
                                               (position-paragraph snd-start)))))))))))))
+
+    (define/private (first-sexp-is-keyword? contains)
+      (let ([fst-end (get-forward-sexp contains)])
+        (and fst-end
+             (let ([fst-start (get-backward-sexp fst-end)])
+               (and fst-start
+                    (equal? (classify-position fst-start) 'hash-colon-keyword))))))
     
     (define/public (tabify-selection [start-pos (get-start-position)]
                                      [end-pos (get-end-position)])
       (unless (is-stopped?) 
         (define first-para (position-paragraph start-pos))
         (define end-para (position-paragraph end-pos))
+        (define tabifying-multiple-paras? (not (= first-para end-para)))
         (with-handlers ([exn:break?
                          (λ (x) #t)])
           (dynamic-wind
@@ -750,7 +782,14 @@
            (λ ()
              (let loop ([para first-para])
                (when (<= para end-para)
-                 (tabify (paragraph-start-position para))
+                 (define start (paragraph-start-position para))
+                 (define end (paragraph-end-position para))
+                 (define skip-this-line?
+                   (and tabifying-multiple-paras?
+                        (for/and ([i (in-range start (+ end 1))])
+                          (char-whitespace? (get-character i)))))
+                 (unless skip-this-line?
+                   (tabify start))
                  (parameterize-break #t (void))
                  (loop (add1 para))))
              (when (and (>= (position-paragraph start-pos) end-para)
@@ -768,8 +807,8 @@
              (when (< first-para end-para)
                (end-busy-cursor)))))))
     
-    (define (tabify-all) (tabify-selection 0 (last-position)))
-    (define (insert-return)
+    (define/public (tabify-all) (tabify-selection 0 (last-position)))
+    (define/public (insert-return)
       (begin-edit-sequence #t #f)
       (define end-of-whitespace (get-start-position))
       (define start-cutoff
@@ -793,7 +832,7 @@
                new-pos))))
       (end-edit-sequence))
     
-    (define (calc-last-para last-pos)
+    (define/public (calc-last-para last-pos)
       (let ([last-para (position-paragraph last-pos #t)])
         (if (and (> last-pos 0)
                  (> last-para 0))
@@ -804,55 +843,53 @@
                          last-para)))
             last-para)))
     
-    (define comment-out-selection 
-      (lambda ([start-pos (get-start-position)] 
-               [end-pos (get-end-position)]) 
-        (begin-edit-sequence) 
-        (let ([first-pos-is-first-para-pos? 
-               (= (paragraph-start-position (position-paragraph start-pos)) 
-                  start-pos)]) 
-          (let* ([first-para (position-paragraph start-pos)] 
-                 [last-para (calc-last-para end-pos)]) 
-            (let para-loop ([curr-para first-para]) 
-              (when (<= curr-para last-para) 
-                (let ([first-on-para (paragraph-start-position curr-para)]) 
-                  (insert #\; first-on-para) 
-                  (para-loop (add1 curr-para)))))) 
-          (when first-pos-is-first-para-pos? 
-            (set-position 
-             (paragraph-start-position (position-paragraph (get-start-position))) 
-             (get-end-position)))) 
-        (end-edit-sequence) 
-        #t)) 
+    (define/public (comment-out-selection [start-pos (get-start-position)] 
+                                          [end-pos (get-end-position)])
+      (begin-edit-sequence) 
+      (let ([first-pos-is-first-para-pos? 
+             (= (paragraph-start-position (position-paragraph start-pos)) 
+                start-pos)]) 
+        (let* ([first-para (position-paragraph start-pos)] 
+               [last-para (calc-last-para end-pos)]) 
+          (let para-loop ([curr-para first-para]) 
+            (when (<= curr-para last-para) 
+              (let ([first-on-para (paragraph-start-position curr-para)]) 
+                (insert #\; first-on-para) 
+                (para-loop (add1 curr-para)))))) 
+        (when first-pos-is-first-para-pos? 
+          (set-position 
+           (paragraph-start-position (position-paragraph (get-start-position))) 
+           (get-end-position)))) 
+      (end-edit-sequence) 
+      #t) 
     
-    (define box-comment-out-selection
-      (lambda ([_start-pos 'start]
-               [_end-pos 'end])
-        (let ([start-pos (if (eq? _start-pos 'start)
-                             (get-start-position)
-                             _start-pos)]
-              [end-pos (if (eq? _end-pos 'end)
-                           (get-end-position)
-                           _end-pos)])
-          (begin-edit-sequence)
-          (split-snip start-pos)
-          (split-snip end-pos)
-          (let* ([cb (instantiate comment-box:snip% ())]
-                 [text (send cb get-editor)])
-            (let loop ([snip (find-snip start-pos 'after-or-none)])
-              (cond
-                [(not snip) (void)]
-                [((get-snip-position snip) . >= . end-pos) (void)]
-                [else
-                 (send text insert (send snip copy)
-                       (send text last-position)
-                       (send text last-position))
-                 (loop (send snip next))]))
-            (delete start-pos end-pos)
-            (insert cb start-pos)
-            (set-position start-pos start-pos))
-          (end-edit-sequence)
-          #t)))
+    (define/public (box-comment-out-selection [_start-pos 'start]
+                                              [_end-pos 'end])
+      (let ([start-pos (if (eq? _start-pos 'start)
+                           (get-start-position)
+                           _start-pos)]
+            [end-pos (if (eq? _end-pos 'end)
+                         (get-end-position)
+                         _end-pos)])
+        (begin-edit-sequence)
+        (split-snip start-pos)
+        (split-snip end-pos)
+        (let* ([cb (instantiate comment-box:snip% ())]
+               [text (send cb get-editor)])
+          (let loop ([snip (find-snip start-pos 'after-or-none)])
+            (cond
+              [(not snip) (void)]
+              [((get-snip-position snip) . >= . end-pos) (void)]
+              [else
+               (send text insert (send snip copy)
+                     (send text last-position)
+                     (send text last-position))
+               (loop (send snip next))]))
+          (delete start-pos end-pos)
+          (insert cb start-pos)
+          (set-position start-pos start-pos))
+        (end-edit-sequence)
+        #t))
     
     ;; uncomment-box/selection : -> void
     ;; uncomments a comment box, if the focus is inside one.
@@ -872,44 +909,43 @@
       (end-edit-sequence)
       #t)
     
-    (define uncomment-selection
-      (lambda ([start-pos (get-start-position)]
-               [end-pos (get-end-position)])
-        (let ([snip-before (find-snip start-pos 'before-or-none)]
-              [snip-after (find-snip start-pos 'after-or-none)])
+    (define/public (uncomment-selection [start-pos (get-start-position)]
+                                        [end-pos (get-end-position)])
+      (let ([snip-before (find-snip start-pos 'before-or-none)]
+            [snip-after (find-snip start-pos 'after-or-none)])
           
-          (begin-edit-sequence)
-          (cond
-            [(and (= start-pos end-pos)
-                  snip-before
-                  (is-a? snip-before comment-box:snip%))
-             (extract-contents start-pos snip-before)]
-            [(and (= start-pos end-pos)
-                  snip-after
-                  (is-a? snip-after comment-box:snip%))
-             (extract-contents start-pos snip-after)]
-            [(and (= (+ start-pos 1) end-pos)
-                  snip-after
-                  (is-a? snip-after comment-box:snip%))
-             (extract-contents start-pos snip-after)]
-            [else
-             (let* ([last-pos (last-position)]
-                    [first-para (position-paragraph start-pos)]
-                    [last-para (calc-last-para end-pos)])
-               (let para-loop ([curr-para first-para])
-                 (when (<= curr-para last-para)
-                   (let ([first-on-para
-                          (skip-whitespace  (paragraph-start-position curr-para)
-                                            'forward
-                                            #f)])
-                     (split-snip first-on-para)
-                     (when (and (< first-on-para last-pos)
-                                (char=? #\; (get-character first-on-para))
-                                (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
-                       (delete first-on-para (+ first-on-para 1)))
-                     (para-loop (add1 curr-para))))))])
-          (end-edit-sequence))
-        #t))
+        (begin-edit-sequence)
+        (cond
+          [(and (= start-pos end-pos)
+                snip-before
+                (is-a? snip-before comment-box:snip%))
+           (extract-contents start-pos snip-before)]
+          [(and (= start-pos end-pos)
+                snip-after
+                (is-a? snip-after comment-box:snip%))
+           (extract-contents start-pos snip-after)]
+          [(and (= (+ start-pos 1) end-pos)
+                snip-after
+                (is-a? snip-after comment-box:snip%))
+           (extract-contents start-pos snip-after)]
+          [else
+           (let* ([last-pos (last-position)]
+                  [first-para (position-paragraph start-pos)]
+                  [last-para (calc-last-para end-pos)])
+             (let para-loop ([curr-para first-para])
+               (when (<= curr-para last-para)
+                 (let ([first-on-para
+                        (skip-whitespace  (paragraph-start-position curr-para)
+                                          'forward
+                                          #f)])
+                   (split-snip first-on-para)
+                   (when (and (< first-on-para last-pos)
+                              (char=? #\; (get-character first-on-para))
+                              (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
+                     (delete first-on-para (+ first-on-para 1)))
+                   (para-loop (add1 curr-para))))))])
+        (end-edit-sequence))
+      #t)
     
     ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
     ;; copies the contents of the comment-box-snip out of the snip
@@ -987,13 +1023,12 @@
             (set-position end-pos)
             (bell))
         #t))
-    [define flash-forward-sexp
-      (λ (start-pos)
-        (let ([end-pos (get-forward-sexp start-pos)])
-          (if end-pos 
-              (flash-on end-pos (add1 end-pos))
-              (bell)) 
-          #t))]
+    (define/public (flash-forward-sexp start-pos)
+      (let ([end-pos (get-forward-sexp start-pos)])
+        (if end-pos 
+            (flash-on end-pos (add1 end-pos))
+            (bell)) 
+        #t))
     (define/public (get-backward-sexp start-pos)
       (let* ([limit (get-limit start-pos)]
              [end-pos (backward-match start-pos limit)]
@@ -1012,89 +1047,82 @@
                     end-pos)))
             ;; can't go backward at all:
             #f)))
-    [define flash-backward-sexp
-      (λ (start-pos)
-        (let ([end-pos (get-backward-sexp start-pos)])
-          (if end-pos
-              (flash-on end-pos (add1 end-pos))
-              (bell))
-          #t))]
-    [define backward-sexp
-      (λ (start-pos)
-        (let ([end-pos (get-backward-sexp start-pos)])
-          (if end-pos
-              (set-position end-pos)
-              (bell))
-          #t))]
-    [define find-up-sexp
-      (λ (start-pos)
-        (let* ([limit-pos (get-limit start-pos)]
-               [exp-pos
-                (backward-containing-sexp start-pos limit-pos)])
+    (define/public (flash-backward-sexp start-pos)
+      (let ([end-pos (get-backward-sexp start-pos)])
+        (if end-pos
+            (flash-on end-pos (add1 end-pos))
+            (bell))
+        #t))
+    (define/public (backward-sexp start-pos)
+      (let ([end-pos (get-backward-sexp start-pos)])
+        (if end-pos
+            (set-position end-pos)
+            (bell))
+        #t))
+    (define/public (find-up-sexp start-pos)
+      (let* ([limit-pos (get-limit start-pos)]
+             [exp-pos
+              (backward-containing-sexp start-pos limit-pos)])
           
-          (if (and exp-pos (> exp-pos limit-pos))
-              (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
-                     [paren-pos
-                      (λ (paren-pair)
-                        (find-string
-                         (car paren-pair)
-                         'backward
-                         in-start-pos
-                         limit-pos))])
-                (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
-                              (cond
-                                [(null? parens) null]
-                                [else 
-                                 (let ([pos (paren-pos (car parens))])
-                                   (if pos
-                                       (cons pos (loop (cdr parens)))
-                                       (loop (cdr parens))))]))])
-                  (if (null? poss) ;; all finds failed
-                      #f
-                      (- (apply max poss) 1)))) ;; subtract one to move outside the paren
-              #f)))]
-    [define up-sexp
-      (λ (start-pos)
-        (let ([exp-pos (find-up-sexp start-pos)])
-          (if exp-pos
-              (set-position exp-pos)
-              (bell))
-          #t))]
-    [define find-down-sexp
-      (λ (start-pos)
-        (let loop ([pos start-pos])
-          (let ([next-pos (get-forward-sexp pos)])
-            (if (and next-pos (> next-pos pos))
-                (let ([back-pos
-                       (backward-containing-sexp (sub1 next-pos) pos)])
-                  (if (and back-pos
-                           (> back-pos pos))
-                      back-pos
-                      (loop next-pos)))
-                #f))))]
-    [define down-sexp
-      (λ (start-pos)
-        (let ([pos (find-down-sexp start-pos)])
-          (if pos
-              (set-position pos)
-              (bell))
-          #t))]
-    [define remove-parens-forward
-      (λ (start-pos)
-        (let* ([pos (skip-whitespace start-pos 'forward #f)]
-               [first-char (get-character pos)]
-               [paren? (or (char=? first-char #\()
-                           (char=? first-char #\[)
-                           (char=? first-char #\{))]
-               [closer (and paren? 
-                            (get-forward-sexp pos))])
-          (if (and paren? closer)
-              (begin (begin-edit-sequence #t #f)
-                     (delete pos (add1 pos))
-                     (delete (-  closer 2) (- closer 1))
-                     (end-edit-sequence))
-              (bell))
-          #t))]
+        (if (and exp-pos (> exp-pos limit-pos))
+            (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
+                   [paren-pos
+                    (λ (paren-pair)
+                      (find-string
+                       (car paren-pair)
+                       'backward
+                       in-start-pos
+                       limit-pos))])
+              (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
+                            (cond
+                              [(null? parens) null]
+                              [else 
+                               (let ([pos (paren-pos (car parens))])
+                                 (if pos
+                                     (cons pos (loop (cdr parens)))
+                                     (loop (cdr parens))))]))])
+                (if (null? poss) ;; all finds failed
+                    #f
+                    (- (apply max poss) 1)))) ;; subtract one to move outside the paren
+            #f)))
+    (define/public (up-sexp start-pos)
+      (let ([exp-pos (find-up-sexp start-pos)])
+        (if exp-pos
+            (set-position exp-pos)
+            (bell))
+        #t))
+    (define/public (find-down-sexp start-pos)
+      (let loop ([pos start-pos])
+        (let ([next-pos (get-forward-sexp pos)])
+          (if (and next-pos (> next-pos pos))
+              (let ([back-pos
+                     (backward-containing-sexp (sub1 next-pos) pos)])
+                (if (and back-pos
+                         (> back-pos pos))
+                    back-pos
+                    (loop next-pos)))
+              #f))))
+    (define/public (down-sexp start-pos)
+      (let ([pos (find-down-sexp start-pos)])
+        (if pos
+            (set-position pos)
+            (bell))
+        #t))
+    (define/public (remove-parens-forward start-pos)
+      (let* ([pos (skip-whitespace start-pos 'forward #f)]
+             [first-char (get-character pos)]
+             [paren? (or (char=? first-char #\()
+                         (char=? first-char #\[)
+                         (char=? first-char #\{))]
+             [closer (and paren? 
+                          (get-forward-sexp pos))])
+        (if (and paren? closer)
+            (begin (begin-edit-sequence #t #f)
+                   (delete pos (add1 pos))
+                   (delete (-  closer 2) (- closer 1))
+                   (end-edit-sequence))
+            (bell))
+        #t))
     
     (define/private (select-text f forward?)
       (define start-pos (get-start-position))
@@ -1111,11 +1139,11 @@
           (extend-position new-pos)
           (bell))
           #t)
-    (public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
-    [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
-    [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
-    [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
-    [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
+
+    (define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t))
+    (define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f))
+    (define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f))
+    (define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t))
     
     (define/public (introduce-let-ans pos)
       (dynamic-wind
@@ -1261,10 +1289,9 @@
                                 (for-each (λ (s) (insert s start-1)) snips-2/rev)
                                 (set-position end-2)
                                 (end-edit-sequence)))))))))))
-    [define tab-size 8]
-    (public get-tab-size set-tab-size)
-    [define get-tab-size (λ () tab-size)]
-    [define set-tab-size (λ (s) (set! tab-size s))]
+    (define tab-size 8)
+    (define/public (get-tab-size) tab-size)
+    (define/public (set-tab-size s) (set! tab-size s))
     
     (define/override (get-start-of-line pos)
       (define para (position-paragraph pos))
@@ -1332,7 +1359,7 @@
       (cond
         [(and (eq? type 'symbol)
               (string? lexeme)
-              (get-keyword-type lexeme tabify-pref))
+              (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)]))
@@ -1351,9 +1378,9 @@
                           (|[| |]|)
                           (|{| |}|))))))
 
-;; get-keyword-type : string (list ht regexp regexp regexp)
-;;                 -> (or/c #f 'lambda 'define 'begin 'for/fold)
-(define (get-keyword-type text pref)
+;; 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)
   (define ht (car pref))
   (define beg-reg (list-ref pref 1))
   (define def-reg (list-ref pref 2))

gui-lib/framework/private/search.rkt

@@ -1,99 +1,116 @@
-#lang scheme/base
+#lang racket/base
 (require racket/contract/base
          racket/class
-         scheme/gui/base)
+         racket/gui/base)
 
-(provide/contract
- [find-string-embedded
-  (->* ((is-a?/c text%)
-        string?)
-       ((symbols 'forward 'backward)
-        (or/c (symbols 'start) number?)
-        (or/c (symbols 'eof) number?)
-        boolean?
-        boolean?
-        boolean?)
-      (values (is-a?/c editor<%>)
-              (or/c false/c number?)))])
+(provide
+ (contract-out
+  [find-string-embedded
+   (->* ((is-a?/c text%)
+         string?)
+        ((or/c 'forward 'backward)
+         (or/c 'start number?)
+         (or/c 'eof number?)
+         boolean?
+         boolean?
+         boolean?)
+        (values (is-a?/c editor<%>)
+                (or/c #f number?)))]))
 
-(define find-string-embedded
-  (lambda (edit
-           str
-           [direction 'forward]
-           [start 'start]
-           [end 'eof]
-           [get-start #t]
-           [case-sensitive? #t]
-           [pop-out? #f])
-    (let/ec k
-      (let* ([start (if (eq? start 'start) 
-                        (send edit get-start-position)
-                        start)]
-             [end (if (eq? 'eof end)
-                      (if (eq? direction 'forward)
-                          (send edit last-position)
-                          0)
-                      end)]
-             [flat (send edit find-string str direction
-                         start end get-start
-                         case-sensitive?)]
-             [pop-out
-              (λ ()
-                (let ([admin (send edit get-admin)])
-                  (if (is-a? admin editor-snip-editor-admin<%>)
-                      (let* ([snip (send admin get-snip)]
-                             [edit-above (send (send snip get-admin) get-editor)]
-                             [pos (send edit-above get-snip-position snip)]
-                             [pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
-                        (find-string-embedded
-                         edit-above
-                         str
-                         direction 
-                         pop-out-pos
-                         (if (eq? direction 'forward) 'eof 0)
-                         get-start
-                         case-sensitive?
-                         pop-out?))
-                      (values edit #f))))])
-        (let loop ([current-snip (send edit find-snip start
-                                       (if (eq? direction 'forward)
-                                           'after-or-none
-                                           'before-or-none))])
-          (let ([next-loop
-                 (λ ()
-                   (if (eq? direction 'forward)
-                       (loop (send current-snip next))
-                       (loop (send current-snip previous))))])
-            (cond
-              [(or (not current-snip)
-                   (and flat
-                        (let* ([start (send edit get-snip-position current-snip)]
-                               [end (+ start (send current-snip get-count))])
-                          (if (eq? direction 'forward)
-                              (and (<= start flat)
-                                   (< flat end))
-                              (and (< start flat)
-                                   (<= flat end))))))
-               (if (and (not flat) pop-out?)
-                   (pop-out)
-                   (values edit flat))]
-              [(is-a? current-snip editor-snip%)
-               (let-values ([(embedded embedded-pos)
-                             (let ([media (send current-snip get-editor)])
-                               (if (and media
-                                        (is-a? media text%))
-                                   (begin
-                                     (find-string-embedded 
-                                      media 
-                                      str
-                                      direction
-                                      (if (eq? 'forward direction)
-                                          0
-                                          (send media last-position))
-                                      'eof
-                                      get-start case-sensitive?))
-                                   (values #f #f)))])
-                 (if (not embedded-pos)
-                     (next-loop)
-                     (values embedded embedded-pos)))]
-              [else (next-loop)])))))))
+(define (find-string-embedded a-text
+                              str
+                              [direction 'forward]
+                              [start 'start]
+                              [end 'eof]
+                              [get-start #t]
+                              [case-sensitive? #t]
+                              [pop-out? #f])
+  (let/ec k
+    (let loop ([a-text a-text]
+               [start start]
+               [end end])
+      (define found (send a-text find-string-embedded str direction start end get-start case-sensitive?))
+      (define (done)
+        (cond
+          [(not found)
+           (k a-text found)]
+          [else
+           (let loop ([a-text a-text]
+                      [found found])
+             (cond
+               [(number? found)
+                (k a-text found)]
+               [else (loop (car found) (cdr found))]))]))
+      (when found (done))
+      (unless pop-out? (done))
+      (define a-text-admin (send a-text get-admin))
+      (unless (is-a? a-text-admin editor-snip-editor-admin<%>) (done))
+      (define editor-snip (send a-text-admin get-snip))
+      (define editor-snip-admin (send editor-snip get-admin))
+      (unless editor-snip-admin (done))
+      (define enclosing-text (send editor-snip-admin get-editor))
+      (unless (is-a? enclosing-text text%) (done))
+      (loop enclosing-text
+            (+ (send enclosing-text get-snip-position editor-snip)
+               (send editor-snip get-count))
+            'eof))))
+
+(module+ test
+  (require rackunit)
+
+  (define abcX (new text%))
+  (send abcX insert "abcX")
+
+  (define abc/abcX/abcQ (new text%))
+  (send abc/abcX/abcQ insert "abc")
+  (send abc/abcX/abcQ insert (new editor-snip% [editor abcX]))
+  (send abc/abcX/abcQ insert "abcQ")
+
+  (define abc//abc/abcX/abcQ//abcZ (new text%))
+  (send abc//abc/abcX/abcQ//abcZ insert "abc")
+  (send abc//abc/abcX/abcQ//abcZ insert (new editor-snip% [editor abc/abcX/abcQ]))
+  (send abc//abc/abcX/abcQ//abcZ insert "abcZ")
+  
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "b" 'forward 0))
+    (check-equal? ta abcX)
+    (check-equal? pos 1))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "c" 'forward 0))
+    (check-equal? ta abcX)
+    (check-equal? pos 2))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "d" 'forward 2))
+    (check-equal? pos #f))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0))
+    (check-equal? ta ta)
+    (check-equal? pos 1))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2))
+    (check-equal? ta abcX)
+    (check-equal? pos 1))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0))
+    (check-equal? ta abcX)
+    (check-equal? pos 3))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t))
+    (check-equal? ta abc/abcX/abcQ)
+    (check-equal? pos 7))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t))
+    (check-equal? ta abc//abc/abcX/abcQ//abcZ)
+    (check-equal? pos 7))
+
+  (let ()
+    (define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t))
+    (check-equal? ta abc/abcX/abcQ)
+    (check-equal? pos 6)))

gui-lib/framework/private/sig.rkt

@@ -154,7 +154,8 @@
      autowrap-mixin
      info-mixin
      file-mixin
-     backup-autosave-mixin))
+     backup-autosave-mixin
+     font-size-message%))
   (define-signature editor^ extends editor-class^
     (get-standard-style-list
      set-standard-style-list-pref-callbacks
@@ -181,6 +182,7 @@
   (define-signature text-class^
     (basic<%>
      line-spacing<%>
+     ascii-art-enlarge-boxes<%>
      first-line<%>
      line-numbers<%>
      foreground-color<%>
@@ -224,6 +226,7 @@
      
      basic-mixin
      line-spacing-mixin
+     ascii-art-enlarge-boxes-mixin
      first-line-mixin
      line-numbers-mixin
      foreground-color-mixin
@@ -258,7 +261,8 @@
      range-color
 
      make-snip-special
-     snip-special?))
+     snip-special?
+     send-snip-to-port))
   
   (define-signature canvas-class^
     (basic<%>

gui-lib/framework/private/text.rkt

@@ -12,9 +12,11 @@
          "autocomplete.rkt"
          mred/mred-sig
          mrlib/interactive-value-port
+         (prefix-in image-core: mrlib/image-core)
          racket/list
          "logging-timer.rkt"
          "coroutine.rkt"
+         "unicode-ascii-art.rkt"
          data/queue
          racket/unit)
 
@@ -748,6 +750,38 @@
               (super on-event event)]
              [else         
               (super on-event event)]))]))
+
+    (define to-invalidate #f)
+    (define/override (on-scroll-to)
+      (super on-scroll-to)
+      (set! to-invalidate (get-region-to-draw)))
+    (define/override (after-scroll-to)
+      (super after-scroll-to)
+      (define (maybe-invalidate)
+        (when to-invalidate
+          (invalidate-bitmap-cache
+           (list-ref to-invalidate 0)
+           (list-ref to-invalidate 1)
+           (list-ref to-invalidate 2)
+           (list-ref to-invalidate 3))
+          (set! to-invalidate #f)))
+      (maybe-invalidate)
+      (set! to-invalidate (get-region-to-draw))
+      (maybe-invalidate))
+    (define/private (get-region-to-draw)
+      (cond
+        [(show-first-line?)
+         (define admin (get-admin))
+         (cond
+           [admin
+            (send admin get-view bx by bw #f #f)
+            (define first-line (get-text 0 (paragraph-end-position 0)))
+            (define-values (tw th _1 _2) (send (get-dc) get-text-extent first-line (get-font)))
+            (list (unbox bx) (unbox by) (unbox bw) (+ th extra-fade-space))]
+           [else #f])]
+        [else #f]))
+
+    (define extra-fade-space 11)
     
     (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
       (unless before?
@@ -755,7 +789,8 @@
           (define admin (get-admin))
           (when admin
             (send admin get-view bx by bw #f #f)
-            (unless (= (unbox by) 0)
+            (define y-coord (unbox by))
+            (unless (= y-coord 0)
               (define draw-first-line-number?
                 (and (is-a? this line-numbers<%>)
                      (send this showing-line-numbers?)))
@@ -772,10 +807,10 @@
               (send dc set-smoothing 'aligned)
               (send dc set-text-mode 'transparent)
               (define-values (tw th _1 _2) (send dc get-text-extent first-line))
-              (define line-height (+ (unbox by) dy th 1))
+              (define line-height (+ y-coord dy th 1))
               (define line-left (+ (unbox bx) dx))
               (define line-right (+ (unbox bx) dx (unbox bw)))
-              
+
               (if w-o-b?
                   (send dc set-pen "white" 1 'solid)
                   (send dc set-pen "black" 1 'solid))
@@ -784,7 +819,7 @@
               (when (eq? (send dc get-smoothing) 'aligned)
                 (define start (if w-o-b? 6/10 3/10))
                 (define end 0)
-                (define steps 10)
+                (define steps (- extra-fade-space 1))
                 (send dc set-pen 
                       (if w-o-b? dark-wob-first-line-color dark-first-line-color) 
                       1
@@ -803,20 +838,20 @@
               (send dc set-alpha 1)
               (send dc set-pen "gray" 1 'transparent)
               (send dc set-brush (if w-o-b? "black" "white") 'solid)
-              (send dc draw-rectangle (+ (unbox bx) dx) (+ (unbox by) dy) (unbox bw) th)
+              (send dc draw-rectangle (+ (unbox bx) dx) (+ y-coord dy) (unbox bw) th)
               (send dc set-text-foreground
                     (send the-color-database find-color
                           (if w-o-b? "white" "black")))
               (define x-start
                 (cond
                   [draw-first-line-number?
-                   (send this do-draw-single-line dc dx dy 0 (unbox by) #f #f)
+                   (send this do-draw-single-line dc dx dy 0 y-coord #f #f)
                    (send dc set-pen (if w-o-b? "white" "black") 1 'solid)
-                   (send this draw-separator dc (unbox by) (+ (unbox by) line-height) dx dy)
+                   (send this draw-separator dc y-coord (+ y-coord line-height) dx dy)
                    (define-values (padding-left _1 _2 _3) (get-padding))
                    padding-left]
                   [else 0]))
-              (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ (unbox by) dy))
+              (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ y-coord dy))
               
               (send dc set-text-foreground old-text-foreground)
               (send dc set-text-mode old-text-mode)
@@ -836,6 +871,89 @@
     
     (super-new)))
 
+(define ascii-art-enlarge-boxes<%> text:ascii-art-enlarge-boxes<%>)
+  
+(define ascii-art-enlarge-boxes-mixin
+  (mixin ((class->interface text%)) (ascii-art-enlarge-boxes<%>)
+    (inherit get-overwrite-mode set-overwrite-mode
+             get-start-position get-end-position set-position last-position
+             get-character
+             begin-edit-sequence end-edit-sequence
+             position-paragraph paragraph-start-position)
+
+    (define ascii-art-enlarge? (preferences:get 'framework:ascii-art-enlarge))
+    (define/public (get-ascii-art-enlarge) ascii-art-enlarge?)
+    (define/public (set-ascii-art-enlarge _e?)
+      (define e? (and _e? #t))
+      (preferences:set 'framework:ascii-art-enlarge e?)
+      (set! ascii-art-enlarge? e?))
+
+    (define/override (on-default-char c)
+      (define kc (send c get-key-code))
+      (define overwrite? (get-overwrite-mode))
+      (cond
+        [(not ascii-art-enlarge?) (super on-default-char c)]
+        [(or (and (char? kc)
+                  (not (member kc '(#\return #\tab #\backspace #\rubout))))
+             (member (send c get-key-code)
+                     going-to-insert-something))
+         (begin-edit-sequence)
+         (define pos (get-start-position))
+         (define widen? (and (= pos (get-end-position))
+                             (or (not overwrite?)
+                                 (insertion-point-at-double-barred-char?))))
+         (when widen?
+           (define para (position-paragraph pos))
+           (define delta-from-start (- pos (paragraph-start-position para)))
+           (widen-unicode-ascii-art-box this pos)
+           (define new-pos (+ (paragraph-start-position para) delta-from-start))
+           (set-position new-pos new-pos))
+         (unless overwrite? (set-overwrite-mode #t))
+         (super on-default-char c)
+         (unless overwrite? (set-overwrite-mode #f))
+         (end-edit-sequence)]
+        [else
+         (super on-default-char c)]))
+
+    (define/override (on-local-char c)
+      (define kc (send c get-key-code))
+      (define overwrite? (get-overwrite-mode))
+      (cond
+        [(not ascii-art-enlarge?) (super on-local-char c)]
+        [(member kc '(numpad-enter #\return))
+         (define pos (get-start-position))
+         (cond
+           [(= pos (get-end-position))
+            (heighten-unicode-ascii-art-box this pos)
+            (define pos-para (position-paragraph pos))
+            (define pos-para-start (paragraph-start-position pos-para))
+            (define next-para-start (paragraph-start-position (+ pos-para 1)))
+            (define just-below-pos (+ next-para-start (- pos pos-para-start)))
+            (define new-pos
+              (let loop ([pos just-below-pos])
+                (cond
+                  [(<= pos next-para-start)
+                   pos]
+                  [(equal? (get-character (- pos 1)) #\║)
+                   pos]
+                  [else (loop (- pos 1))])))
+            (set-position new-pos new-pos)]
+           [else
+            (super on-local-char c)])]
+        [else
+         (super on-local-char c)]))
+
+    (define/private (insertion-point-at-double-barred-char?)
+      (define sp (get-start-position))
+      (and (< sp (last-position))
+           (equal? (get-character sp) #\║)))
+    
+    (super-new)))
+
+(define going-to-insert-something
+  '(multiply
+    add subtract decimal divide
+    numpad0 numpad1 numpad2 numpad3 numpad4 numpad5 numpad6 numpad7 numpad8 numpad9))
 
 (define foreground-color<%>
   (interface (basic<%> editor:standard-style-list<%>)
@@ -1104,7 +1222,7 @@
              get-start-position get-end-position
              unhighlight-ranges/key unhighlight-range highlight-range
              run-after-edit-sequence begin-edit-sequence end-edit-sequence
-             find-string get-admin position-line
+             find-string find-string-embedded get-admin position-line
              in-edit-sequence? get-pos/text-dc-location
              get-canvas get-top-level-window)
     
@@ -1145,7 +1263,7 @@
            (car to-replace-highlight)))
 
     ;; NEW METHOD: used for test suites
-    (define/public (search-updates-pending?) 
+    (define/public (search-updates-pending?)
       (or update-replace-bubble-callback-running?
           search-position-callback-running?
           search-coroutine))
@@ -1234,16 +1352,16 @@
                 (when to-replace-highlight
                   (unhighlight-replace))]
                [else
-                (define next (do-search (get-start-position) 'eof))
+                (define next (do-search (get-start-position)))
                 (begin-edit-sequence #t #f)
                 (cond
-                  [next
+                  [(number? next)
                    (unless (and to-replace-highlight
                                 (= (car to-replace-highlight) next)
                                 (= (cdr to-replace-highlight) 
-                                   (+ next (string-length searching-str))))
+                                   (string-length searching-str)))
                      (replace-highlight->normal-hit)
-                     (define pr (cons next (+ next (string-length searching-str))))
+                     (define pr (cons next (string-length searching-str)))
                      (unhighlight-hit pr)
                      (highlight-replace pr))]
                   [else
@@ -1260,16 +1378,27 @@
         (queue-callback
          (λ ()
            (when searching-str
-             (define count 0)
-             (define start-pos (get-start-position))
-             (hash-for-each
-              search-bubble-table
-              (λ (k v)
-                (when (<= (car k) start-pos)
-                  (set! count (+ count 1)))))
+             (define start-pos (get-focus-editor-start-position))
+             (define count
+               (for/sum ([(k v) (in-hash search-bubble-table)])
+                 (define n (if (search-result-compare <= (car k) start-pos) 1 0))
+                 n))
              (update-before-caret-search-hit-count count))
            (set! search-position-callback-running? #f))
          #f)))
+
+    (define/private (get-focus-editor-start-position)
+      (let loop ([txt this])
+        (define focus (send txt get-focus-snip))
+        (define embedded
+          (and focus
+               (is-a? focus editor-snip%)
+               (is-a? (send focus get-editor) text%)
+               (send focus get-editor)))
+        (cond
+          [embedded
+           (cons embedded (loop embedded))]
+          [else (send txt get-start-position)])))
     
     (define/private (update-before-caret-search-hit-count c)
       (unless (equal? before-caret-search-hit-count c)
@@ -1296,7 +1425,7 @@
               (clear-yellow)
               (set! clear-yellow void)
               (when (and searching-str (= (string-length searching-str) (- end start)))
-                (when (do-search start end)
+                (when (find-string searching-str 'forward start end #t case-sensitive?)
                   (set! clear-yellow (highlight-range
                                       start end
                                       (if (preferences:get 'framework:white-on-black?)
@@ -1315,7 +1444,7 @@
             (list (list to-replace-highlight 'dark-search-color))
             (list))
         (hash-map search-bubble-table
-                  (λ (x true) 
+                  (λ (x _true)
                     (list x (if replace-mode? 'light-search-color 'normal-search-color)))))
        string<?
        #:key (λ (x) (format "~s" (car x)))))
@@ -1380,31 +1509,40 @@
         [searching-str
          (define new-search-bubbles '())
          (define new-replace-bubble #f)
-         (define first-hit (do-search 0 'eof))
+         (define first-hit (do-search 0))
+         
          (define-values (this-search-hit-count this-before-caret-search-hit-count)
            (cond
              [first-hit
-              (define sp (get-start-position))
+              (define sp (get-focus-editor-start-position))
               (let loop ([bubble-start first-hit]
                          [search-hit-count 0]
-                         [before-caret-search-hit-count 1])
+                         [before-caret-search-hit-count (if (search-result-compare < first-hit sp) 1 0)])
                 (maybe-pause)
-                (define bubble-end (+ bubble-start (string-length searching-str)))
-                (define bubble (cons bubble-start bubble-end))
+                (define bubble-end (search-result+ bubble-start (string-length searching-str)))
+                (define bubble (cons bubble-start (string-length searching-str)))
                 (define this-bubble
                   (cond
                     [(and replace-mode?
                           (not new-replace-bubble)
-                          (<= sp bubble-start))
+                          (search-result-compare <= sp bubble-start))
                      (set! new-replace-bubble bubble)
                      'the-replace-bubble]
                     [else
                      bubble]))
                 (set! new-search-bubbles (cons this-bubble new-search-bubbles))
-                      
-                (define next (do-search bubble-end 'eof))
+
+                (define next (do-search bubble-end))
+
+                (when (> (let loop ([x bubble-start])
+                           (cond
+                             [(number? x) 1]
+                             [else (+ 1 (loop (cdr x)))]))
+                         3)
+                  (car))
+                
                 (define next-before-caret-search-hit-count
-                  (if (and next (< next sp))
+                  (if (and next (search-result-compare < next sp))
                       (+ 1 before-caret-search-hit-count)
                       before-caret-search-hit-count))
                 (cond
@@ -1454,15 +1592,82 @@
                 (send w search-hits-changed)]
                [(is-a? w area<%>)
                 (loop (send w get-parent))]))))))
-    
+
+    (define/private (search-result+ search-result num)
+      (let loop ([search-result search-result])
+        (cond
+          [(number? search-result) (+ search-result num)]
+          [(cons? search-result)
+           (cons (car search-result)
+                 (loop (cdr search-result)))])))
+
+    (define/private (search-result-compare lt l r)
+      (let loop ([txt this]
+                 [l l]
+                 [r r])
+        (define (get-the-position x)
+          ;; the zeros shouldn't happen because the editors should still
+          ;; be in the main text object while we are doing stuff with them
+          (define admin (send x get-admin))
+          (cond
+            [(is-a? admin editor-snip-editor-admin<%>)
+             (or (send txt get-snip-position (send admin get-snip)) 0)]
+            [else
+             0]))
+        (cond
+          [(and (number? l) (number? r)) (lt l r)]
+          [(or (number? l) (number? r))
+           (define ln (if (number? l) l (get-the-position (car l))))
+           (define rn (if (number? r) r (get-the-position (car r))))
+           (lt ln rn)]
+          [else
+           (cond
+             [(equal? (car l) (car r))
+              (loop (car l) (cdr l) (cdr r))]
+             [else
+              (lt (get-the-position (car l))
+                  (get-the-position (car r)))])])))
+
+    (define all-txt-with-regions-to-clear (make-hasheq))
     (define/private (clear-all-regions) 
       (when to-replace-highlight 
         (unhighlight-replace))
-      (unhighlight-ranges/key 'plt:framework:search-bubbles)
+      (for ([(txt _) (in-hash all-txt-with-regions-to-clear)])
+        (send txt unhighlight-ranges/key 'plt:framework:search-bubbles))
+      (set! all-txt-with-regions-to-clear (make-hasheq))
       (set! search-bubble-table (make-hash)))
     
-    (define/private (do-search start end)
-      (find-string searching-str 'forward start end #t case-sensitive?))
+    (define/private (do-search start)
+      (define context (list this))
+      (define position
+        (let loop ([start start])
+          (cond
+            [(number? start) start]
+            [else
+             (set! context (cons (car start) context))
+             (loop (cdr start))])))
+      (let loop ([position position]
+                 [context context])
+        (define found-at-this-level
+          (send (car context) find-string-embedded searching-str 'forward position 'eof #t case-sensitive?))
+        (cond
+          [found-at-this-level
+           (let loop ([context context])
+             (cond
+               [(null? (cdr context)) found-at-this-level]
+               [else (cons (car context)
+                           (loop (cdr context)))]))]
+          [(null? (cdr context)) #f]
+          [else
+           (define admin (send (car context) get-admin))
+           (cond
+             [(is-a? admin editor-snip-editor-admin<%>)
+              (define snip (send admin get-snip))
+              (loop (+ (send (second context) get-snip-position snip)
+                       (send snip get-count))
+                    (cdr context))]
+             [else
+              (error 'framework/private/text.rkt::searching "admin went wrong ~s" admin)])])))
     
     ;; INVARIANT: when a search bubble is highlighted,
     ;; the search-bubble-table has it mapped to #t
@@ -1472,40 +1677,61 @@
     
     ;; this method may be called with bogus inputs (ie a pair that has no highlight)
     ;; but only when there is a pending "erase all highlights and recompute everything" callback
-    (define/private (unhighlight-hit pair)
-      (hash-remove! search-bubble-table pair)
-      (unhighlight-range (car pair) (cdr pair) 
-                         (if replace-mode? light-search-color normal-search-color)
-                         #f
-                         'hollow-ellipse))
-    (define/private (highlight-hit pair)
-      (hash-set! search-bubble-table pair #t)
-      (highlight-range (car pair) (cdr pair) 
-                       (if replace-mode? light-search-color normal-search-color)
-                       #f
-                       'low
-                       'hollow-ellipse
-                       #:key 'plt:framework:search-bubbles
-                       #:adjust-on-insert/delete? #t))
+    (define/private (unhighlight-hit bubble)
+      (hash-remove! search-bubble-table bubble)
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
+      (when txt
+        (send txt unhighlight-range
+              start end
+              (if replace-mode? light-search-color normal-search-color)
+              #f
+              'hollow-ellipse)))
+    (define/private (highlight-hit bubble)
+      (hash-set! search-bubble-table bubble #t)
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
+      (when txt
+        (hash-set! all-txt-with-regions-to-clear txt #t)
+        (send txt highlight-range
+              start end
+              (if replace-mode? light-search-color normal-search-color)
+              #f
+              'low
+              'hollow-ellipse
+              #:key 'plt:framework:search-bubbles
+              #:adjust-on-insert/delete? #t)))
     
     ;; INVARIANT: the "next to replace" highlight is always
     ;; saved in 'to-replace-highlight'
     (define/private (unhighlight-replace)
-      (unhighlight-range (car to-replace-highlight)
-                         (cdr to-replace-highlight)
-                         dark-search-color
-                         #f
-                         'hollow-ellipse)
+      (define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight))
+      (when txt
+        (send txt unhighlight-range
+              start end
+              dark-search-color
+              #f
+              'hollow-ellipse))
       (set! to-replace-highlight #f))
     
     (define/private (highlight-replace new-to-replace)
       (set! to-replace-highlight new-to-replace)
-      (highlight-range (car to-replace-highlight)
-                       (cdr to-replace-highlight)
-                       dark-search-color
-                       #f
-                       'high
-                       'hollow-ellipse))
+      (define-values (txt start end) (get-highlighting-text-and-range new-to-replace))
+      (when txt
+        (send txt highlight-range
+              start end
+              dark-search-color
+              #f
+              'high
+              'hollow-ellipse)))
+
+    (define/private (get-highlighting-text-and-range bubble)
+      (let loop ([txt this]
+                 [txt/pr (car bubble)])
+        (cond
+          [(number? txt/pr)
+           (if (is-a? txt text:basic<%>)
+               (values txt txt/pr (+ txt/pr (cdr bubble)))
+               (values #f #f #f))]
+          [else (loop (car txt/pr) (cdr txt/pr))])))
     
     (define/private (unhighlight-anchor)
       (unhighlight-range anchor-pos anchor-pos "red" #f 'dot)
@@ -2237,22 +2463,29 @@
       [the-snipclass
        (define base (new editor-stream-out-bytes-base%))
        (define stream (make-object editor-stream-out% base))
+       (write-editor-global-header stream)
        (send snip write stream)
+       (write-editor-global-footer stream)
        (snip-special snip
                      (send the-snipclass get-classname)
                      (send base get-bytes))]
       [else
        (snip-special snip #f #f)]))
+  ;; -> (or/c (is-a?/c snip%) exn:fail?)
   (define (snip-special->snip snip-special)
     (define the-name (snip-special-name snip-special))
     (define snipclass (and the-name (send (get-the-snip-class-list) find the-name)))
     (cond
       [snipclass
-       (define base (make-object editor-stream-in-bytes-base%
-                      (snip-special-bytes snip-special)))
-       (define es (make-object editor-stream-in% base))
-       (or (send snipclass read es)
-           (snip-special-snip snip-special))]
+       (with-handlers ([exn:fail? values])
+         (define base (make-object editor-stream-in-bytes-base%
+                        (snip-special-bytes snip-special)))
+         (define es (make-object editor-stream-in% base))
+         (read-editor-global-header es)
+         (define the-snip (send snipclass read es))
+         (read-editor-global-footer es)
+         (or the-snip
+             (snip-special-snip snip-special)))]
       [else
        (snip-special-snip snip-special)]))
   
@@ -2606,7 +2839,7 @@
     (define/private (do-insertion txts showing-input?)
       (define locked? (is-locked?))
       (define sf? (get-styles-fixed))
-      (begin-edit-sequence)
+      (begin-edit-sequence #f)
       (lock #f)
       (set-styles-fixed #f)
       (set! allow-edits? #t)
@@ -2615,12 +2848,26 @@
           [(null? txts) (void)]
           [else 
            (define fst (car txts))
-           (define str/snp
+           (define-values (str/snp style)
              (cond
                [(snip-special? (car fst))
-                (snip-special->snip (car fst))]
-               [else (car fst)]))
-           (define style (cdr fst))
+                (define the-snip
+                  (snip-special->snip (car fst)))
+                (if (exn:fail? the-snip)
+                    (values (apply
+                             string-append
+                             "error while rendering snip "
+                             (format "~s" (snip-special-name (car fst)))
+                             ":\n"
+                             (exn-message the-snip)
+                             "  context:\n"
+                             (for/list ([x (in-list (continuation-mark-set->context
+                                                     (exn-continuation-marks
+                                                      the-snip)))])
+                               (format "   ~s\n" x)))
+                            (add-standard error-style-name))
+                    (values the-snip (cdr fst)))]
+               [else (values (car fst) (cdr fst))]))
            
            (define inserted-count
              (if (is-a? str/snp snip%)
@@ -2828,8 +3075,8 @@
                  ;; don't want to set the port-print-handler here; 
                  ;; instead drracket sets the global-port-print-handler
                  ;; to catch fractions and the like
-                 (set-interactive-write-handler port)
-                 (set-interactive-display-handler port))])
+                 (set-interactive-write-handler port #:snip-handler send-snip-to-port)
+                 (set-interactive-display-handler port #:snip-handler send-snip-to-port))])
           (install-handlers out-port)
           (install-handlers err-port)
           (install-handlers value-port))))
@@ -2968,6 +3215,30 @@
     (define in-port (make-in-port-with-a-name (get-port-name)))
     (define in-box-port (make-in-box-port-with-a-name (get-port-name)))))
 
+(define (send-snip-to-port value port)
+  (cond
+    [(image-core:image? value)
+     ;; do this computation here so that any failures
+     ;; during drawing happen under the user's custodian
+     (image-core:compute-image-cache value)
+
+     ;; once that is done, we trust the value not to run
+     ;; any code that the user wrote, so just send it over
+     (write-special value port)]
+    [else
+     (define str (format "~s" value))
+     (cond
+       ;; special case these snips as they don't work properly
+       ;; without this and we aren't ready to break them yet
+       ;; and image-core:image? should be safe-- there is no user
+       ;; code in those images to fail
+       [(or (regexp-match? #rx"plot-snip%" str)
+            (regexp-match? #rx"pict3d%" str))
+        (write-special (send value copy) port)]
+       [else
+        (write-special (make-snip-special (send value copy)) port)])])
+  (void))
+
 (define input-box<%>
   (interface ((class->interface text%))
     ))
@@ -4309,7 +4580,7 @@ designates the character that triggers autocompletion
       (inner (void) after-edit-sequence))
     
     (define/private (draw-numbers dc left top right bottom dx dy start-line end-line)
-      (unless (left . > . (line-x-coordinate dc dx))
+      (unless ((+ left dx) . > . (line-x-coordinate dc dx))
         (define last-paragraph #f)
         (define insertion-para
           (let ([sp (get-start-position)])
@@ -4400,12 +4671,12 @@ designates the character that triggers autocompletion
 
     (define/private (text-width dc stuff)
       (define-values (font-width font-height baseline space)
-                     (send dc get-text-extent stuff))
+        (send dc get-text-extent stuff (get-style-font)))
       font-width)
 
     (define/private (text-height dc stuff)
       (define-values (font-width height baseline space)
-                     (send dc get-text-extent stuff))
+        (send dc get-text-extent stuff (get-style-font)))
       height)
 
     (define old-clipping #f)
@@ -4570,7 +4841,7 @@ designates the character that triggers autocompletion
      #t)
      
     (super-new)))
-  
+
 (define basic% (basic-mixin (editor:basic-mixin text%)))
 (define line-spacing% (line-spacing-mixin basic%))
 (define hide-caret/selection% (hide-caret/selection-mixin line-spacing%))

gui-lib/framework/private/unicode-ascii-art.rkt

@@ -0,0 +1,450 @@
+#lang racket/base
+(require racket/gui/base
+         racket/class
+         racket/contract
+         2d/dir-chars)
+
+(provide normalize-unicode-ascii-art-box
+         widen-unicode-ascii-art-box
+         heighten-unicode-ascii-art-box
+         center-in-unicode-ascii-art-box)
+
+(define (widen-unicode-ascii-art-box t orig-pos)
+  (widen/highten-unicode-ascii-art-box t orig-pos #t))
+
+(define (heighten-unicode-ascii-art-box t orig-pos)
+  (widen/highten-unicode-ascii-art-box t orig-pos #f))
+
+(define (widen/highten-unicode-ascii-art-box t orig-pos widen?)
+  (define start-pos (scan-for-start-pos t orig-pos))
+  (when start-pos 
+    (send t begin-edit-sequence)
+    (define-values (start-x start-y) (pos->xy t orig-pos))
+    (define start-major (if widen? start-x start-y))
+    (define min-minor #f)
+    (define max-minor #f)
+    (trace-unicode-ascii-art-box 
+     t start-pos #f 
+     (λ (pos x y i-up? i-dn? i-lt? i-rt?)
+       (define minor (if widen? y x))
+       (define major (if widen? x y))
+       (when (= major start-major)
+         (unless min-minor
+           (set! min-minor minor)
+           (set! max-minor minor))
+         (set! min-minor (min minor min-minor))
+         (set! max-minor (max minor max-minor)))))
+    (cond
+      [widen?
+       (define to-adjust 0)
+       (for ([minor (in-range max-minor (- min-minor 1) -1)])
+         (define-values (pos char) (xy->pos t start-major minor))
+         (when (< pos start-pos)
+           (set! to-adjust (+ to-adjust 1)))
+         (send t insert
+               (cond
+                 [(member char lt-chars) #\═]
+                 [else #\space])
+               pos pos))
+       (send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))]
+      [else
+       (define-values (min-pos _1) (xy->pos t min-minor start-major))
+       (define-values (max-pos _2) (xy->pos t max-minor start-major))
+       (define para (send t position-paragraph max-pos))
+       (define para-start (send t paragraph-start-position para))
+       (define para-end (send t paragraph-end-position para))
+       (send t insert "\n" para-end para-end)
+       (for ([to-copy-pos (in-range para-start (+ max-pos 1))])
+         (define to-insert-pos (+ para-end 1 (- to-copy-pos para-start)))
+         (define char
+           (cond
+             [(< to-copy-pos min-pos) " "]
+             [else
+              (define above-char (send t get-character to-copy-pos))
+              (if (and (member above-char dn-chars)
+                       (member above-char double-barred-chars))
+                  "║"
+                  " ")]))
+         (send t insert char to-insert-pos to-insert-pos))
+       (void)])
+    (send t end-edit-sequence)))
+
+(define (normalize-unicode-ascii-art-box t pos)
+  (define start-pos (scan-for-start-pos t pos))
+  (when start-pos
+    (send t begin-edit-sequence)
+    (trace-unicode-ascii-art-box 
+     t start-pos #f 
+     (λ (pos x y i-up? i-dn? i-lt? i-rt?)
+       (cond
+         [(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
+         [(and i-dn? i-lt? i-rt?)       (set-c t pos "╦")]
+         [(and i-up? i-lt? i-rt?)       (set-c t pos "╩")]
+         [(and i-up? i-dn? i-rt?)       (set-c t pos "╠")]
+         [(and i-up? i-dn? i-lt?)       (set-c t pos "╣")]
+         [(and i-up? i-lt?)             (set-c t pos "╝")]
+         [(and i-up? i-rt?)             (set-c t pos "╚")]
+         [(and i-dn? i-lt?)             (set-c t pos "╗")]
+         [(and i-dn? i-rt?)             (set-c t pos "╔")]
+         [(or i-up? i-dn?)              (set-c t pos "║")]
+         [else                          (set-c t pos "═")])))
+     (send t end-edit-sequence)))
+
+(define (center-in-unicode-ascii-art-box txt insertion-pos)
+  (define (find-something start-pos inc char-p?)
+    (define-values (x y) (pos->xy txt start-pos))
+    (let loop ([pos start-pos])
+      (cond
+        [(char-p? (send txt get-character pos))
+         pos]
+        [else
+         (define new-pos (inc pos))
+         (cond
+           [(<= 0 new-pos (send txt last-position))
+            (define-values (x2 y2) (pos->xy txt new-pos))
+            (cond
+              [(= y2 y)
+               (loop new-pos)]
+              [else #f])]
+           [else #f])])))
+  
+  (define (adjust-space before-space after-space pos)
+    (cond
+      [(< before-space after-space) 
+       (send txt insert (make-string (- after-space before-space) #\space) pos pos)]
+      [(> before-space after-space) 
+       (send txt delete pos (+ pos (- before-space after-space)))]))
+  
+  (define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
+  (define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
+  (when (and left-bar right-bar (< left-bar right-bar))
+    (define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
+    (define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
+    (when (and left-space-edge right-space-edge)
+      (define before-left-space-count (- left-space-edge left-bar 1))
+      (define before-right-space-count (- right-bar right-space-edge 1))
+      (define tot-space (+ before-left-space-count before-right-space-count))
+      (define after-left-space-count (floor (/ tot-space 2)))
+      (define after-right-space-count (ceiling (/ tot-space 2)))
+      (send txt begin-edit-sequence)
+      (adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
+      (adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
+      (send txt end-edit-sequence))))
+
+(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
+  (define visited (make-hash))
+  (let loop ([pos start-pos])
+    (unless (hash-ref visited pos #f)
+      (hash-set! visited pos #t)
+      (define-values (x y) (pos->xy t pos))
+      (define c (send t get-character pos))
+      (define-values (up upc) (xy->pos t x (- y 1)))
+      (define-values (dn dnc) (xy->pos t x (+ y 1)))
+      (define-values (lt ltc) (xy->pos t (- x 1) y))
+      (define-values (rt rtc) (xy->pos t (+ x 1) y))
+      (define (interesting-dir? dir-c dir-chars) 
+        (or (and (not only-double-barred-chars?)
+                 (member dir-c adjustable-chars)
+                 (member c dir-chars))
+            (and (member dir-c double-barred-chars)
+                 (member c double-barred-chars))))
+      (define i-up? (interesting-dir? upc up-chars))
+      (define i-dn? (interesting-dir? dnc dn-chars))
+      (define i-lt? (interesting-dir? ltc lt-chars))
+      (define i-rt? (interesting-dir? rtc rt-chars))
+      (f pos x y i-up? i-dn? i-lt? i-rt?)
+      (when i-up? (loop up))
+      (when i-dn? (loop dn))
+      (when i-lt? (loop lt))
+      (when i-rt? (loop rt)))))
+
+(define (scan-for-start-pos t pos)
+  (define-values (x y) (pos->xy t pos))
+  (findf
+   (λ (p) (adj? t p))
+   (for*/list ([xadj '(0 -1)]
+               [yadj '(0 -1 1)])
+     (define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
+     d)))
+       
+(define (adj? t pos)
+  (and pos 
+       (member (send t get-character pos) 
+               adjustable-chars)))
+
+(define (set-c t pos s)
+  (unless (equal? (string-ref s 0) (send t get-character pos))
+    (send t delete pos (+ pos 1))
+    (send t insert s pos pos)))
+
+(define (pos->xy text pos)
+  (define para (send text position-paragraph pos))
+  (define start (send text paragraph-start-position para))
+  (values (- pos start) para))
+
+(define (xy->pos text x y)
+  (cond
+    [(and (<= 0 x) (<= 0 y (send text last-paragraph)))
+     (define para-start (send text paragraph-start-position y))
+     (define para-end (send text paragraph-end-position y))
+     (define pos (+ para-start x))
+     (define res-pos
+       (and (< pos para-end)
+            ;; the newline at the end of the
+            ;; line is not on the line, so use this guard
+            pos))
+     (if res-pos
+         (values res-pos (send text get-character res-pos))
+         (values #f #f))]
+    [else (values #f #f)]))
+
+(module+ test
+  (require rackunit 
+           racket/gui/base)
+  (define sa string-append)
+  
+  (define (first-value-xy->pos a b c)
+    (define-values (d e) (xy->pos a b c))
+    d)
+  
+  (let ([t (new text%)])
+    (send t insert (sa "abc\n"
+                       "d\n"
+                       "ghi\n"))
+    (check-equal? (first-value-xy->pos t 0 0) 0)
+    (check-equal? (first-value-xy->pos t 1 0) 1)
+    (check-equal? (first-value-xy->pos t 0 1) 4)
+    (check-equal? (first-value-xy->pos t 3 0) #f)
+    (check-equal? (first-value-xy->pos t 0 3) #f)
+    (check-equal? (first-value-xy->pos t 1 1) #f)
+    (check-equal? (first-value-xy->pos t 2 1) #f)
+    (check-equal? (first-value-xy->pos t 0 2) 6)
+    (check-equal? (first-value-xy->pos t 1 2) 7)
+    (check-equal? (first-value-xy->pos t 2 -1) #f)
+    (check-equal? (first-value-xy->pos t -1 0) #f)
+    (check-equal? (first-value-xy->pos t 2 2) 8)
+    (check-equal? (first-value-xy->pos t 2 3) #f))
+  
+  (let ([t (new text%)])
+    (send t insert (sa "abc\n"
+                       "d\n"
+                       "ghi"))
+    (check-equal? (first-value-xy->pos t 2 2) 8)
+    (check-equal? (first-value-xy->pos t 2 3) #f))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append "+-+\n"
+                                  "| |\n"
+                                  "+-+\n"))
+    (normalize-unicode-ascii-art-box t 0)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔═╗\n"
+                   "║ ║\n"
+                   "╚═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append "+=+\n"
+                                  "| |\n"
+                                  "+=+\n"))
+    (normalize-unicode-ascii-art-box t 0)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔═╗\n"
+                   "║ ║\n"
+                   "╚═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append "+-+-+\n"
+                                  "| | |\n"
+                                  "+-+-+\n"
+                                  "| | |\n"
+                                  "+-+-+\n"))
+    (normalize-unicode-ascii-art-box t 0)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔═╦═╗\n"
+                   "║ ║ ║\n"
+                   "╠═╬═╣\n"
+                   "║ ║ ║\n"
+                   "╚═╩═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "╔═══╗\n"
+                    "║ - ║\n"
+                    "╚═══╝\n"))
+    
+    (normalize-unicode-ascii-art-box t 0)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔═══╗\n"
+                   "║ - ║\n"
+                   "╚═══╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "╔═╦═╗\n"
+                    "║ ║ ║\n"
+                    "╠═╬═╣\n"
+                    "║ ║ ║\n"
+                    "╚═╩═╝\n"))
+    (send t set-position 1 1)
+    (widen-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-start-position) 2)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔══╦═╗\n"
+                   "║  ║ ║\n"
+                   "╠══╬═╣\n"
+                   "║  ║ ║\n"
+                   "╚══╩═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "╔═╦═╗\n"
+                    "║ ║ ║\n"
+                    "╠═╬═╣\n"
+                    "║ ║ ║\n"
+                    "╚═╩═╝\n"))
+    (send t set-position 8 8)
+    (widen-unicode-ascii-art-box t 8)
+    (check-equal? (send t get-start-position) 10)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔══╦═╗\n"
+                   "║  ║ ║\n"
+                   "╠══╬═╣\n"
+                   "║  ║ ║\n"
+                   "╚══╩═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "╔═╦═╗\n"
+                    "║ ║ ║\n"
+                    "╠═╬═╣\n"
+                    "║ ║ ║\n"))
+    (send t set-position 8 8)
+    (widen-unicode-ascii-art-box t 8)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔══╦═╗\n"
+                   "║  ║ ║\n"
+                   "╠══╬═╣\n"
+                   "║  ║ ║\n")))
+
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "╔═╦═╗\n"
+                    "║ ║ ║\n"
+                    "╠═╬═╣\n"
+                    "║ ║ ║\n"
+                    "╚═╩═╝\n"))
+    (send t set-position 8 8)
+    (heighten-unicode-ascii-art-box t 8)
+    (check-equal? (send t get-start-position) 8)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "╔═╦═╗\n"
+                   "║ ║ ║\n"
+                   "║ ║ ║\n"
+                   "╠═╬═╣\n"
+                   "║ ║ ║\n"
+                   "╚═╩═╝\n")))
+
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "1 ╔═╦═╗\n"
+                    "2 ║ ║ ║\n"
+                    "3 ╠═╬═╣\n"
+                    "4 ║ ║ ║\n"
+                    "5 ╚═╩═╝\n"))
+    (send t set-position 11 11)
+    (heighten-unicode-ascii-art-box t 11)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "1 ╔═╦═╗\n"
+                   "2 ║ ║ ║\n"
+                   "  ║ ║ ║\n"
+                   "3 ╠═╬═╣\n"
+                   "4 ║ ║ ║\n"
+                   "5 ╚═╩═╝\n")))
+
+  (let ([t (new text%)])
+    (send t insert (string-append
+                    "1 ╔═╦═╗\n"
+                    "2 ║ ║ ║\n"
+                    "3 ╠═╬═╣\n"
+                    "4 ║ ║ ║\n"
+                    "5 ╚═╩═╝\n"))
+    (send t set-position 19 19)
+    (heighten-unicode-ascii-art-box t 19)
+    (check-equal? (send t get-text)
+                  (string-append
+                   "1 ╔═╦═╗\n"
+                   "2 ║ ║ ║\n"
+                   "3 ╠═╬═╣\n"
+                   "  ║ ║ ║\n"
+                   "4 ║ ║ ║\n"
+                   "5 ╚═╩═╝\n")))
+  
+  (let ([t (new text%)])
+    (send t insert "║ x   ║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║  x  ║\n"))
+  
+  (let ([t (new text%)])
+    (send t insert "║x    ║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║  x  ║\n"))
+  
+  (let ([t (new text%)])
+    (send t insert "║    x║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║  x  ║\n"))
+  
+  (let ([t (new text%)])
+    (send t insert "║abcde║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║abcde║\n"))
+  
+  (let ([t (new text%)])
+    (send t insert "║║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║║\n"))
+  
+  (let ([t (new text%)])
+    (send t insert "║abcde \n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  "║abcde \n"))
+  
+  (let ([t (new text%)])
+    (send t insert " abcde║\n")
+    (center-in-unicode-ascii-art-box t 1)
+    (check-equal? (send t get-text)
+                  " abcde║\n")))
+
+#;
+(module+ main
+  (require framework)
+  (define f (new frame% [label ""] [width 500] [height 500]))
+  (define t (new (ascii-art-enlarge-boxes-mixin racket:text%)))
+  (send t set-overwrite-mode #t)
+  (define ec (new editor-canvas% [parent f] [editor t]))
+  (send t insert
+        (string-append
+         "╔═╦═╗\n"
+         "║ ║ ║\n"
+         "║ ║ ║\n"
+         "╠═╬═╣\n"
+         "║ ║ ║\n"
+         "╚═╩═╝\n"))
+  (send t set-position 14 14)
+  (send f show #t))
+

gui-lib/framework/splash.rkt

@@ -3,26 +3,59 @@
 (require racket/class
          racket/file
          racket/gui/base
+         racket/contract
          (for-syntax racket/base))
 
-(provide get-splash-bitmap
-         set-splash-bitmap
-         get-splash-canvas
-         get-splash-eventspace
-         get-splash-paint-callback
-         set-splash-paint-callback
-         start-splash 
-         shutdown-splash
-         close-splash
-         add-splash-icon
-         set-splash-progress-bar?!
-         set-splash-char-observer
-         set-splash-event-callback
-         get-splash-event-callback
-         set-refresh-splash-on-gauge-change?!
-         get-splash-width
-         get-splash-height
-         refresh-splash)
+(provide
+ (contract-out
+  [get-splash-bitmap (-> (or/c #f (is-a?/c bitmap%)))]
+  [set-splash-bitmap (-> (is-a?/c bitmap%) void?)]
+  [get-splash-canvas (-> (is-a?/c canvas%))]
+  [get-splash-eventspace (-> eventspace?)]
+  [get-splash-paint-callback (-> procedure?)]
+  [set-splash-paint-callback (-> (or/c (-> (is-a?/c dc<%>)
+                                           exact-nonnegative-integer?
+                                           exact-nonnegative-integer?
+                                           exact-nonnegative-integer?
+                                           exact-nonnegative-integer?
+                                           any)
+                                       (-> (is-a?/c dc<%>)
+                                           any))
+                                 void?)]
+  [start-splash
+   (->* ((or/c path-string?
+               (is-a?/c bitmap%)
+               (vector/c (or/c (-> (is-a?/c dc<%>) void?)
+                               (-> (is-a?/c dc<%>)
+                                   exact-nonnegative-integer?
+                                   exact-nonnegative-integer?
+                                   exact-nonnegative-integer?
+                                   exact-nonnegative-integer?
+                                   any))
+                         exact-nonnegative-integer?
+                         exact-nonnegative-integer?))
+         string?
+         exact-nonnegative-integer?)
+        (#:allow-funny?
+         boolean?
+         #:frame-icon
+         (or/c #f
+               (is-a?/c bitmap%)
+               (cons/c (is-a?/c bitmap%)
+                       (is-a?/c bitmap%))))
+        void?)]
+  
+  [shutdown-splash (-> void?)]
+  [close-splash (-> void?)]
+  [add-splash-icon (-> (is-a?/c bitmap%) real? real? void?)]
+  [set-splash-progress-bar?! (-> boolean? void?)]
+  [set-splash-char-observer (-> procedure? void?)]
+  [set-splash-event-callback (-> procedure? void?)]
+  [get-splash-event-callback (-> procedure?)]
+  [set-refresh-splash-on-gauge-change?! (-> procedure? void?)]
+  [get-splash-width (-> exact-nonnegative-integer?)]
+  [get-splash-height (-> exact-nonnegative-integer?)]
+  [refresh-splash (-> void?)]))
 
 (define splash-bitmap #f)
 (define splash-cache-bitmap #f)
@@ -62,26 +95,29 @@
                                                     e ...)))
              (printf "finishing ~a\n" line))))]))
 
-(define (get-splash-bitmap) splash-bitmap)
+(define (get-splash-bitmap) (on-splash-eventspace/ret splash-bitmap))
 (define (set-splash-bitmap bm) 
-  (set! splash-bitmap bm)
-  (on-splash-eventspace (send splash-canvas on-paint)))
+  (on-splash-eventspace
+   (set! splash-bitmap bm)
+   (send splash-canvas on-paint)))
 (define (get-splash-canvas) splash-canvas)
 (define (get-splash-eventspace) splash-eventspace)
 
-(define (get-splash-paint-callback) splash-paint-callback)
-(define (set-splash-paint-callback sp) 
-  (set! splash-paint-callback sp)
-  (refresh-splash))
+(define (get-splash-paint-callback) (on-splash-eventspace/ret splash-paint-callback))
+(define (set-splash-paint-callback sp)
+  (on-splash-eventspace
+   (set! splash-paint-callback sp)
+   (refresh-splash)))
 
 (define (get-splash-width) (on-splash-eventspace/ret (send splash-canvas get-width)))
 (define (get-splash-height) (on-splash-eventspace/ret (send splash-canvas get-height)))
 
-(define (set-splash-event-callback cb) (set! splash-event-callback cb))
-(define (get-splash-event-callback cb) splash-event-callback)
+(define (set-splash-event-callback cb) (on-splash-eventspace (set! splash-event-callback cb)))
+(define (get-splash-event-callback) (on-splash-eventspace/ret splash-event-callback))
 
 (define (refresh-splash-on-gauge-change? start range) #f)
-(define (set-refresh-splash-on-gauge-change?! f) (set! refresh-splash-on-gauge-change? f))
+(define (set-refresh-splash-on-gauge-change?! f)
+  (on-splash-eventspace (set! refresh-splash-on-gauge-change? f)))
 
 (define (refresh-splash)
   
@@ -118,7 +154,9 @@
     [else
      (parameterize ([current-eventspace splash-eventspace])
        (queue-callback
-        recompute-bitmap/refresh))]))
+        recompute-bitmap/refresh))])
+  
+  (void))
 
 (define (set-splash-progress-bar?! b?) 
   (on-splash-eventspace/ret
@@ -143,8 +181,9 @@
 (define-struct icon (bm x y))
 (define icons null)
 (define (add-splash-icon bm x y)
-  (set! icons (cons (make-icon bm x y) icons))
-  (refresh-splash))
+  (on-splash-eventspace
+   (set! icons (cons (make-icon bm x y) icons))
+   (refresh-splash)))
 
 (define (start-splash splash-draw-spec _splash-title width-default 
                       #:allow-funny? [allow-funny? #f]
@@ -170,12 +209,10 @@
          (send splash-tlw set-icon frame-icon (send frame-icon get-loaded-mask) 'both)))
      
      (cond
-       [(or (path? splash-draw-spec)
-            (string? splash-draw-spec)
+       [(or (path-string? splash-draw-spec)
             (is-a? splash-draw-spec bitmap%))
         (cond
-          [(or (path? splash-draw-spec)
-               (string? splash-draw-spec))
+          [(path-string? splash-draw-spec)
            (unless (file-exists? splash-draw-spec)
              (eprintf "WARNING: bitmap path ~s not found\n" splash-draw-spec)
              (no-splash))
@@ -201,12 +238,7 @@
         (send splash-canvas min-height (vector-ref splash-draw-spec 2))
         (set! splash-cache-bitmap (make-screen-bitmap
                                     (vector-ref splash-draw-spec 1)
-                                    (vector-ref splash-draw-spec 2)))]
-       [(not splash-draw-spec)
-        (no-splash)]
-       [else
-        (eprintf "WARNING: unknown splash spec: ~s" splash-draw-spec)
-        (no-splash)])
+                                    (vector-ref splash-draw-spec 2)))])
      
      (send splash-tlw reflow-container)
      
@@ -260,23 +292,20 @@
          (refresh-splash)))))
   (old-load f expected))
 
-(let-values ([(make-compilation-manager-load/use-compiled-handler
-               manager-trace-handler)
-              (if (or (getenv "PLTDRCM")
-                      (getenv "PLTDRDEBUG"))
-                  (parameterize ([current-namespace (make-base-namespace)])
-                    (values
-                     (dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
-                     (dynamic-require 'compiler/cm 'manager-trace-handler)))
-                  (values #f #f))])
+(let ([make-compilation-manager-load/use-compiled-handler
+       (if (or (getenv "PLTDRCM")
+               (getenv "PLTDRDEBUG"))
+           (parameterize ([current-namespace (make-base-namespace)])
+             (dynamic-require 'compiler/cm
+                              'make-compilation-manager-load/use-compiled-handler))
+           #f)])
   
   (current-load
    (let ([old-load (current-load)])
      (λ (f expected)
        (splash-load-handler old-load f expected))))
   
-  (when (and make-compilation-manager-load/use-compiled-handler
-             manager-trace-handler)
+  (when make-compilation-manager-load/use-compiled-handler
     (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
     (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))))
 

gui-lib/framework/test.rkt

@@ -644,16 +644,24 @@
            (error menu-tag "active frame does not have menu bar"))
          (send menu-bar on-demand)
          (let* ([items (send menu-bar get-items)])
-           (let loop ([items items]
+           (let loop ([all-items-this-level items]
+                      [items items]
                       [this-name (car item-names)]
                       [wanted-names (cdr item-names)])
              (cond
                [(null? items)
-                (error 'menu-select "didn't find a menu: ~e, entire list: ~e" this-name item-names)]
+                (error 'menu-select
+                       "didn't find a menu: ~e, desired list: ~e, all items at this level ~e"
+                       this-name
+                       item-names
+                       (map (λ (x) (and (is-a? x labelled-menu-item<%>)
+                                        (send x get-plain-label)))
+                            all-items-this-level))]
                [else (let ([i (car items)])
                        (cond
                          [(not (is-a? i labelled-menu-item<%>))
-                          (loop (cdr items)
+                          (loop all-items-this-level
+                                (cdr items)
                                 this-name
                                 wanted-names)]
                          [(string=? this-name (send i get-plain-label))
@@ -664,12 +672,14 @@
                             [(and (not (null? wanted-names))
                                   (is-a? i menu-item-container<%>))
                              (loop (send i get-items)
+                                   (send i get-items)
                                    (car wanted-names)
                                    (cdr wanted-names))]
                             [else
                              (error menu-tag "no menu matching ~e" item-names)])]
                          [else
-                          (loop (cdr items)
+                          (loop all-items-this-level
+                                (cdr items)
                                 this-name
                                 wanted-names)]))]))))])))
 

gui-lib/info.rkt

@@ -4,15 +4,15 @@
 
 (define deps '("srfi-lite-lib"
                "data-lib"
-               ["base" #:version "6.2.900.17"]
+               ["base" #:version "6.5.0.2"]
                "syntax-color-lib"
-               ["draw-lib" #:version "1.9"]
-               "snip-lib"
+               ["draw-lib" #:version "1.13"]
+               ["snip-lib" #:version "1.2"]
                "wxme-lib"
                "pict-lib"
                "scheme-lib"
                "scribble-lib"
-               "string-constants-lib"
+               ["string-constants-lib" #:version "1.9"]
                "option-contract-lib"
                "2d-lib"
                "compatibility-lib"
@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.18")
+(define version "1.28")

gui-lib/mred/info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define version '(400))
-(define post-install-collection "installer.rkt")
+(define install-collection "installer.rkt")
 (define copy-man-pages '("mred.1"))
 
 (define release-note-files

gui-lib/mred/installer.rkt

@@ -3,44 +3,71 @@
          compiler/embed
          racket/file
          racket/path
+         setup/dirs
          setup/cross-system)
 
-(provide post-installer)
+(provide installer)
 
 ;; Platforms that get a `MrEd' executable:
 (define mred-exe-systems '(unix))
 
-(define (post-installer path coll user?)
+(define (installer path coll user? no-main?)
+  (unless no-main?
+    (do-installer path coll user? #f)
+    (when (and (not user?)
+               (find-config-tethered-console-bin-dir))
+      (do-installer path coll #f #t)))
+  (when (find-addon-tethered-console-bin-dir)
+    (do-installer path coll #t #t)))
+
+(define (do-installer path coll user? tethered?)
   (define variants (available-mred-variants))
   (when (memq (cross-system-type) mred-exe-systems)
     (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?))
-         #:cmdline '("-I" "scheme/gui/init")
+         (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"))
          #:variant v
          #:launcher? #t
          #:gracket? #t
          #:aux `((relative? . ,(not user?)))))))
   ;; add a mred-text executable that uses the -z flag (preferring a script)
+  (define tether-mode (and tethered? (if user? 'addon 'config)))
   (for ([vs '((script-3m 3m) (script-cgc cgc))])
     (let ([v (findf (lambda (v) (memq v variants)) vs)])
       (when v
         (parameterize ([current-launcher-variant v])
           (make-gracket-launcher
+           #:tether-mode tether-mode
            '("-I" "scheme/gui/init" "-z")
-           (prep-dir (mred-program-launcher-path "mred-text" #:user? user?))
-           `([relative? . ,(not user?)] [subsystem . console] [single-instance? . #f]))))))
+           (prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
+           `([relative? . ,(not (or user? tethered?))]
+             [subsystem . console]
+             [single-instance? . #f]))))))
   ;; add bin/mred script under OS X
   (when (eq? 'macosx (cross-system-type))
     (for ([v variants] #:when (memq v '(script-3m script-cgc)))
       (parameterize ([current-launcher-variant v])
         (make-gracket-launcher
-         '()
-         (prep-dir (mred-program-launcher-path "MrEd" #:user? user?))
-         '([exe-name . "GRacket"] [relative? . ,(not user?)] [exe-is-gracket . #t]))))))
+         #:tether-mode tether-mode
+         null
+         (prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
+         `([exe-name . "GRacket"]
+           [relative? . ,(not (or user? tethered?))]
+           [exe-is-gracket . #t]))))))
 
 (define (prep-dir p)
   (define dir (path-only p))
   (make-directory* dir)
   p)
+
+(define (addon-flags)
+  (append
+   (config-flags)
+   (list "-A" (path->string (find-system-path 'addon-dir)))))
+
+(define (config-flags)
+  (list "-C" (path->string (find-config-dir))))

gui-lib/mred/mred-sig.rkt

@@ -4,6 +4,7 @@ add-color<%>
 add-editor-keymap-functions
 add-pasteboard-keymap-functions
 add-text-keymap-functions
+any-control+alt-is-altgr
 append-editor-font-menu-items
 append-editor-operation-menu-items
 application-about-handler

gui-lib/mred/private/mrcanvas.rkt

@@ -320,6 +320,8 @@
     (define scroll-to-last? #f)
     (define scroll-bottom? #f)
     (define/public (call-as-primary-owner f) (send wx call-as-primary-owner f))
+    (define/public (set-scroll-via-copy s) (send wx set-scroll-via-copy s))
+    (define/public (get-scroll-via-copy) (send wx get-scroll-via-copy))
     (define allow-scroll-to-last
       (entry-point 
        (case-lambda

gui-lib/mred/private/mred.rkt

@@ -143,6 +143,7 @@
 	     scroll-event%
 	     special-control-key
 	     special-option-key
+             any-control+alt-is-altgr
              map-command-as-meta-key
 	     label->plain-label
 	     write-editor-global-footer

gui-lib/mred/private/mrpanel.rkt

@@ -182,14 +182,29 @@
                                     panel))]
            [as-canvas? (lambda () (or (memq 'vscroll style)
                                       (memq 'auto-vscroll style)
+                                      (memq 'hide-vscroll style)
                                       (memq 'hscroll style)
-                                      (memq 'auto-hscroll style)))])
+                                      (memq 'auto-hscroll style)
+                                      (memq 'hide-hscroll style)))])
       (check-container-parent cwho parent)
       (check-style cwho #f (append '(border deleted)
                                    (if can-canvas?
-                                       '(hscroll vscroll auto-hscroll auto-vscroll)
+                                       '(hscroll vscroll
+                                         auto-hscroll auto-vscroll 
+                                         hide-hscroll hide-vscroll)
                                        null))
                    style)
+
+      (define (add-scrolls style)
+        (append
+         (if (memq 'hide-vscroll style) 
+             '(auto-vscroll)
+             null)
+         (if (memq 'hide-hscroll style) 
+             '(auto-hscroll)
+             null)
+         style))
+
       (as-entry
        (lambda ()
          (super-instantiate
@@ -208,7 +223,7 @@
                                                         wx-canvas-panel%
                                                         wx-panel%)])
                                             this this (mred->wx-container parent)
-                                            (cons 'transparent style)
+                                            (cons 'transparent (add-scrolls style))
                                             (get-initial-label)))
                    wx)
            (lambda () wx)

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

@@ -99,7 +99,13 @@
 
 (define-objc-class RacketGCGLView NSOpenGLView
   #:mixins (KeyMouseResponder)
-  [wxb])
+  [wxb]
+  (-a #:async-apply (box (void))
+      _void (drawRect: [_NSRect r])
+      (when wxb
+        (let ([wx (->wx wxb)])
+          (when wx
+            (send wx draw-gc-background))))))
 
 (define-objc-class RacketGCWindow NSWindow
   #:mixins (RacketEventspaceMethods)
@@ -202,12 +208,13 @@
 (define NSOpenGLPFASampleBuffers 55)
 (define NSOpenGLPFASamples 56)
 (define NSOpenGLPFAMultisample 59)
+(define NSOpenGLPFAAllowOfflineRenderers 96)
 (define NSOpenGLPFAOpenGLProfile 99)
 
 (define NSOpenGLProfileVersionLegacy #x1000)
 (define NSOpenGLProfileVersion3_2Core #x3200)
 
-(define (gl-config->pixel-format conf)
+(define (gl-config->pixel-format conf allow-offline?)
   (let ([conf (or conf (new gl-config%))])
     (tell (tell NSOpenGLPixelFormat alloc)
           initWithAttributes: #:type (_list i _int)
@@ -218,6 +225,9 @@
                      NSOpenGLProfileVersionLegacy
                      NSOpenGLProfileVersion3_2Core))             
              null)
+           (if allow-offline?
+               (list NSOpenGLPFAAllowOfflineRenderers)
+               null)
            (if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null)
            (if (send conf get-stereo) (list NSOpenGLPFAStereo) null)
            (list
@@ -383,7 +393,9 @@
      (define/override (get-cocoa-content) content-cocoa)
 
      (define is-gl? (and (not is-combo?) (memq 'gl style)))
+     (define want-sync-gl? (and is-gl? gl-config (send gl-config get-sync-swap)))
      (define/public (can-gl?) is-gl?)
+     (define/public (sync-gl?) want-sync-gl?)
 
      (define dc #f)
      (define blits null)
@@ -419,7 +431,7 @@
                     initWithFrame: #:type _NSRect r)
               (let* ([share-context (and gl-config (send gl-config get-share-context))]
                      [context-handle (and share-context (send share-context get-handle))]
-                     [pf (gl-config->pixel-format gl-config)]
+                     [pf (gl-config->pixel-format gl-config #f)]
                      [new-context (and
                                    context-handle
                                    (tell (tell NSOpenGLContext alloc)
@@ -918,9 +930,9 @@
      (define/private (suspend-all-reg-blits)
        (let ([cocoa-win (get-cocoa-window)])
          (for ([r (in-list reg-blits)])
-           (tellv cocoa-win removeChildWindow: (car r))
-           (release (car r))
-           (scheme_remove_gc_callback (cdr r))))
+           (tellv cocoa-win removeChildWindow: (vector-ref r 0))
+           (release (vector-ref r 0))
+           (scheme_remove_gc_callback (vector-ref r 1))))
        (set! reg-blits null))
 
      (define/public (resume-all-reg-blits)
@@ -928,10 +940,10 @@
          (when (pair? blits)
            (set! reg-blits
                  (for/list ([b (in-list blits)])
-                   (let-values ([(x y w h s img) (apply values b)])
-                     (register-one-blit x y w h s img)))))))
+                   (let-values ([(x y w h s img us unimg) (apply values b)])
+                     (register-one-blit x y w h s img us unimg)))))))
 
-     (define/private (register-one-blit x y w h s img)
+     (define/private (register-one-blit x y w h s img us unimg)
        (let ([xb (box x)]
              [yb (box y)])
          (client-to-screen xb yb #f)
@@ -947,7 +959,7 @@
                               backing: #:type _int NSBackingStoreBuffered
                               defer: #:type _BOOL NO))]
                   [glv (and gc-via-gl?
-                            (let ([pf (gl-config->pixel-format #f)])
+                            (let ([pf (gl-config->pixel-format #f #t)])
                               (begin0
                                (tell (tell RacketGCGLView alloc)
                                      initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
@@ -958,10 +970,14 @@
                            (tell (tell NSImageView alloc) init))])
               (cond
                [gc-via-gl?
+                (tellv (tell glv openGLContext) setValues:
+                       #:type (_ptr i _long) 0
+                       forParameter: #:type _int NSOpenGLCPSwapInterval)
                 (tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t)
                 (set-ivar! win wxb (->wxb this))
                 (set-ivar! glv wxb (->wxb this))
-                (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1)
+                (unless (= s 1)
+                  (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1))
                 (tellv (tell win contentView) addSubview: glv)]
                [else
                 (tellv win setAlphaValue: #:type _CGFloat 0.0)
@@ -974,36 +990,56 @@
               (when gc-via-gl?
                 (tellv win orderWindow: #:type _int NSWindowAbove
                        relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber)))
+              (define uninstall-desc
+                (if gc-via-gl?
+                    (if (and unimg
+                             ;; all white?
+                             (not (for/and ([i (in-range 0 (bytes-length unimg) 4)])
+                                    (or (= (bytes-ref unimg i) 0)
+                                        (and (= (bytes-ref unimg (+ 1 i)) 255)
+                                             (= (bytes-ref unimg (+ 2 i)) 255)
+                                             (= (bytes-ref unimg (+ 3 i)) 255))))))
+                        (make-gl-install win glv w h unimg us)
+                        (make-gl-uninstall win glv w h))
+                    (make-gc-action-desc win (selector setAlphaValue:) 0.0)))
               (let ([r (scheme_add_gc_callback
                         (if gc-via-gl?
                             (make-gl-install win glv w h img s)
                             (make-gc-action-desc win (selector setAlphaValue:) 1.0))
-                        (if gc-via-gl?
-                            (make-gl-uninstall win glv w h)
-                            (make-gc-action-desc win (selector setAlphaValue:) 0.0)))])
+                        uninstall-desc)])
                 (when gc-via-gl?
                   (tellv glv release))
-                (cons win r)))))))
+                (vector win r uninstall-desc)))))))
      
      (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
        (let ([on (fix-bitmap-size on w h on-x on-y)]
-             [s (send on get-backing-scale)])
+             [off (and gc-via-gl?
+                       (fix-bitmap-size off w h on-x on-y))]
+             [s (send on get-backing-scale)]
+             [us (send off get-backing-scale)])
+         (define (bm->img on s)
+           (let* ([xw (inexact->exact (ceiling (* s w)))]
+                  [xh (inexact->exact (ceiling (* s h)))]
+                  [rgba (make-bytes (* xw xh 4))])
+             (send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t)
+             rgba))
          (let ([img (if gc-via-gl?
-                        (let* ([xw (inexact->exact (ceiling (* s w)))]
-                               [xh (inexact->exact (ceiling (* s h)))]
-                               [rgba (make-bytes (* xw xh 4))])
-                          (send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t)
-                          rgba)
-                        (bitmap->image on))])
+                        (bm->img on s)
+                        (bitmap->image on))]
+               [unimg (and gc-via-gl? (bm->img off us))])
            (atomically
-            (set! blits (cons (list x y w h s img) blits))
+            (set! blits (cons (list x y w h s img us unimg) blits))
             (when (is-shown-to-root?)
-              (set! reg-blits (cons (register-one-blit x y w h s img) reg-blits)))))))
+              (set! reg-blits (cons (register-one-blit x y w h s img us unimg) reg-blits)))))))
 
      (define/public (unregister-collecting-blits)
        (atomically
         (suspend-all-reg-blits)
-        (set! blits null))))))
+        (set! blits null)))
+
+     (define/public (draw-gc-background)
+       (for ([rb (in-list reg-blits)])
+         (do-gl-action (vector-ref rb 2)))))))
 
 (define canvas-panel%
   (class (panel-mixin canvas%)

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

@@ -29,6 +29,7 @@
 (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void))
 (define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void))
 (define-appserv CGContextStrokePath (_fun _CGContextRef -> _void))
+(define-appserv CGContextClipToRect (_fun _CGContextRef _NSRect -> _void))
 (define-appserv CGContextClipToRects (_fun _CGContextRef (_vector i _NSRect) _size -> _void))
 (define-appserv CGContextSetAlpha (_fun _CGContextRef _CGFloat -> _void))
 

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

@@ -21,7 +21,8 @@
               do-backing-flush)
  display-bitmap-resolution
  make-screen-bitmap
- make-window-bitmap)
+ make-window-bitmap
+ NSOpenGLCPSwapInterval)
 
 (import-class NSOpenGLContext NSScreen NSGraphicsContext NSWindow)
 
@@ -31,43 +32,42 @@
   (class backing-dc%
     (init [(cnvs canvas)]
           transparent?)
-    (define canvas cnvs)
 
-    (inherit end-delay)
+    (define canvas cnvs)
+    (define gl #f)
+    (define trans? transparent?)
+
+    (inherit end-delay internal-get-bitmap internal-copy)
     (super-new [transparent? transparent?])
 
-    (define gl #f)
     (define/override (get-gl-context)
       (and (send canvas can-gl?)
            (let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)])
              (or gl
-                 (let ([g (new (class gl-context%
-                                 (define/override (get-handle) gl-ctx)
-                                 (define/override (do-call-as-current t)
-                                   (dynamic-wind
-                                       (lambda () (tellv gl-ctx makeCurrentContext))
-                                       t
-                                       (lambda () (tellv NSOpenGLContext clearCurrentContext))))
-                                 (define/override (do-swap-buffers)
-                                   (tellv gl-ctx flushBuffer))
-                                 (super-new)))])
-                   ;; Disable screen sync for GL flushBuffer; otherwise,
+                 (let ([g (new dc-gl-context% [gl-ctx gl-ctx])])
+                   ;; By default, disable screen sync for GL flushBuffer; otherwise,
                    ;; flushBuffer can take around 10 msec depending on the timing
                    ;; of event polling, and that can be bad for examples like gears.
-                   ;; Maybe whether to sync with the screen should be a configuration
-                   ;; option, but I can't tell the difference on my screen.
-                   (tellv gl-ctx setValues: 
-                          #:type (_ptr i _long) 0
-                          forParameter: #:type _int NSOpenGLCPSwapInterval)
+                   (unless (send canvas sync-gl?)
+                     (tellv gl-ctx setValues:
+                            #:type (_ptr i _long) 0
+                            forParameter: #:type _int NSOpenGLCPSwapInterval))
                    (set! gl g)
                    g)))))
 
     ;; Use a quartz bitmap so that text looks good:
-    (define trans? transparent?)
     (define/override (make-backing-bitmap w h) 
       (make-window-bitmap w h (send canvas get-cocoa-window) 
                           trans?
                           (send canvas is-flipped?)))
+
+    (def/override (copy [real? x] [real? y] [nonnegative-real? w] [nonnegative-real? h]
+                        [real? x2] [real? y2])
+      (internal-copy x y w h x2 y2
+                     (lambda (cr x y w h x2 y2)
+                       (define bm (internal-get-bitmap))
+                       (and bm
+                            (send bm do-self-copy cr x y w h x2 y2)))))
                    
     (define/override (can-combine-text? sz) #t)
 
@@ -94,6 +94,20 @@
     (define/override (cancel-delay req)
       (send canvas cancel-canvas-flush-delay req))))
 
+(define dc-gl-context%
+  (class gl-context%
+    (init [(gtx gl-ctx)])
+    (define gl-ctx gtx)
+    (define/override (get-handle) gl-ctx)
+    (define/override (do-call-as-current t)
+      (dynamic-wind
+       (lambda () (tellv gl-ctx makeCurrentContext))
+       t
+       (lambda () (tellv NSOpenGLContext clearCurrentContext))))
+    (define/override (do-swap-buffers)
+      (tellv gl-ctx flushBuffer))
+    (super-new)))
+
 (define-local-member-name get-layer)
 
 (define (do-backing-flush canvas dc ctx dx dy)
@@ -145,9 +159,11 @@
                (display-bitmap-resolution 0 void)))
 
 (define (make-window-bitmap w h win [trans? #t] [flipped? #f])
-  (if win
-      (make-object layer-bitmap% w h win trans? flipped?)
-      (make-screen-bitmap w h)))
+  (let ([w (max 1 w)]
+        [h (max 1 h)])
+    (if win
+        (make-object layer-bitmap% w h win trans? flipped?)
+        (make-screen-bitmap w h))))
 
 (define layer-bitmap%
   (class quartz-bitmap%
@@ -157,20 +173,23 @@
     (define layer (make-layer win w h))
     (define layer-w w)
     (define layer-h h)
-    (define/public (get-layer) layer)
 
     (define is-trans? trans?)
+    (define s-bm #f)
 
-    (let ([bs (inexact->exact 
-               (display-bitmap-resolution 0 (lambda () 1)))])
-      (super-make-object w h trans? bs
-                         (let ([cg (CGLayerGetContext layer)])
-                           (unless flipped?
-                             (CGContextTranslateCTM cg 0 h)
-                             (CGContextScaleCTM cg 1 -1))
-                           (unless (= bs 1)
-                             (CGContextScaleCTM cg (/ 1 bs) (/ 1 bs)))
-                           cg)))
+    (define bs (inexact->exact
+                (display-bitmap-resolution 0 (lambda () 1))))
+
+    (super-make-object w h trans? bs
+                       (let ([cg (CGLayerGetContext layer)])
+                         (unless flipped?
+                           (CGContextTranslateCTM cg 0 h)
+                           (CGContextScaleCTM cg 1 -1))
+                         (unless (= bs 1)
+                           (CGContextScaleCTM cg (/ 1 bs) (/ 1 bs)))
+                         cg))
+
+    (define/public (get-layer) layer)
 
     (define/override (draw-bitmap-to cr sx sy dx dy w h alpha clipping-region)
       ;; Called when the destination rectangle is inside the clipping region
@@ -204,13 +223,7 @@
                                        (cairo_matrix_t-y0 m)))
              (cairo_surface_flush s)
              (define cg (cairo_quartz_surface_get_cg_context s))
-             (begin
-               ;; A Cairo flush doesn't reset the clipping region. The
-               ;; implementation of clipping is that there's a saved
-               ;; GState that we can use to get back to the original
-               ;; clipping region, so restore (and save again) that state:
-               (CGContextRestoreGState cg)
-               (CGContextSaveGState cg))
+             (reset-cairo-clipping cg)
              (CGContextSaveGState cg)
              (CGContextConcatCTM cg trans)
              (let ([n (cairo_rectangle_list_t-num_rectangles rs)])
@@ -237,7 +250,37 @@
           #t)]
        [else #f]))
 
-    (define s-bm #f)
+    (define/override (do-self-copy cr x y w h x2 y2)
+      (define bs (get-backing-scale))
+      (define s (cairo_get_target cr))
+      (cairo_surface_flush s)
+      (define cg (cairo_quartz_surface_get_cg_context s))
+      (define orig-size (CGLayerGetSize layer))
+      (atomically
+       (reset-cairo-clipping cg)
+       (CGContextSaveGState cg)
+       (CGContextScaleCTM cg bs (- bs))
+       (define sz (CGLayerGetSize layer))
+       (define lh (NSSize-height sz))
+       (CGContextTranslateCTM cg 0 (- lh))
+       (CGContextClipToRect cg (make-NSRect
+                                (make-NSPoint x2 (- lh (+ y2 h)))
+                                (make-NSSize w h)))
+       (CGContextDrawLayerAtPoint cg
+                                  (make-NSPoint (- x2 x) (- y y2))
+                                  layer)
+       (CGContextRestoreGState cg)
+       (cairo_surface_mark_dirty s))
+      #t)
+    
+    (define/private (reset-cairo-clipping cg)
+      ;; A Cairo flush doesn't reset the clipping region. The
+      ;; implementation of clipping is that there's a saved
+      ;; GState that we can use to get back to the original
+      ;; clipping region, so restore (and save again) that state:
+      (CGContextRestoreGState cg)
+      (CGContextSaveGState cg))
+
     (define/override (get-cairo-surface)
       ;; Convert to a platform bitmap, which Cairo understands
       (let ([t-bm (or s-bm

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

@@ -90,9 +90,9 @@
       (when wxb
         (let ([wx (->wx wxb)])
           (when wx
+            (send wx clean-up)
             (queue-window-event wx (lambda ()
-                                     (send wx queue-on-size)
-                                     (send wx clean-up)))
+                                     (send wx queue-on-size)))
             ;; Live resize:
             (constrained-reply (send wx get-eventspace)
                                (lambda () 
@@ -316,7 +316,10 @@
     (define/public (clean-up)
       ;; When a window is resized, then any drawing that is in flight
       ;; might draw outside the canvas boundaries. Just refresh everything.
-      (tellv cocoa display))
+      (call-with-refreshable
+       (lambda ()
+         (unless (version-10.11-or-later?)
+           (tellv cocoa display)))))
 
     (when label
       (tellv cocoa setTitle: #:type _NSString label))
@@ -352,16 +355,22 @@
                           (not (send p get-sheet)))))
               (let ([p (get-parent)])
                 (send p set-sheet this)
-                (tellv (tell NSApplication sharedApplication)
-                       beginSheet: cocoa
-                       modalForWindow: (send p get-cocoa)
-                       modalDelegate: #f
-                       didEndSelector: #:type _SEL #f
-                       contextInfo: #f))
+                (call-with-refreshable
+                 (lambda ()
+                   (tellv (tell NSApplication sharedApplication)
+                          beginSheet: cocoa
+                          modalForWindow: (send p get-cocoa)
+                          modalDelegate: #f
+                          didEndSelector: #:type _SEL #f
+                          contextInfo: #f))))
               (if float?
-                  (tellv cocoa orderFront: #f)
+                  (call-with-refreshable
+                   (lambda ()
+                     (tellv cocoa orderFront: #f)))
                   (begin
-                    (tellv cocoa makeKeyAndOrderFront: #f)
+                    (call-with-refreshable
+                     (lambda ()
+                       (tellv cocoa makeKeyAndOrderFront: #f)))
                     (when unshown-fullscreen?
                       (set! unshown-fullscreen? #f)
                       (tellv cocoa toggleFullScreen: #f)))))
@@ -377,11 +386,8 @@
               (tellv cocoa deminiaturize: #f)
               (define fs? (fullscreened?))
               (set! unshown-fullscreen? fs?)
-              (tellv cocoa orderOut: #f)
-              (when fs?
-                ;; Need to select another window to get rid of
-                ;; the window's screen:
-                (tellv (get-app-front-window) orderFront: #f)))
+              (tellv cocoa setReleasedWhenClosed: #:type _BOOL #f)
+              (tellv cocoa close))
             (force-window-focus)))
       (register-frame-shown this on?)
       (let ([num (tell #:type _NSInteger cocoa windowNumber)])
@@ -398,12 +404,7 @@
           (when (eventspace-shutdown? es)
             (error (string->symbol
                     (format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
-                   "the eventspace hash been shutdown"))
-          (when (version-10.11-or-later?)
-            ;; Ensure that the basic window background is drawn before
-            ;; we potentially suspend redrawing. Otherwise, the window
-            ;; can start black and end up with a too-dark titlebar.
-            (tellv cocoa display))
+                   "the eventspace has been shutdown"))
           (when saved-child
             (if (eq? (current-thread) (eventspace-handler-thread es))
                 (do-paint-children)
@@ -416,20 +417,53 @@
        (direct-show on?)))
     
     (define flush-disabled 0)
+    (define flush-disable-disabled 0)
     
     (define/public (disable-flush-window)
       (when (zero? flush-disabled)
-        (when (version-10.11-or-later?)
-          (tellv cocoa setAutodisplay: #:type _BOOL #f))
-        (tellv cocoa disableFlushWindow))
+        (when (zero? flush-disable-disabled)
+          (when (version-10.11-or-later?)
+            (tellv cocoa setAutodisplay: #:type _BOOL #f))
+          (tellv cocoa disableFlushWindow)))
       (set! flush-disabled (add1 flush-disabled)))
 
     (define/public (enable-flush-window)
       (set! flush-disabled (sub1 flush-disabled))
       (when (zero? flush-disabled)
-        (tellv cocoa enableFlushWindow)
+        (when (zero? flush-disable-disabled)
+          (tellv cocoa enableFlushWindow))
         (when (version-10.11-or-later?)
-          (tellv cocoa setAutodisplay: #:type _BOOL #t))))
+          (when (zero? flush-disable-disabled)
+            (tellv cocoa setAutodisplay: #:type _BOOL #t))
+          (queue-window-refresh-event
+           this
+           (lambda ()
+             (tellv cocoa displayIfNeeded))))))
+
+    (define/private (call-with-refreshable thunk)
+      (cond
+       [(not (version-10.11-or-later?))
+        (thunk)]
+       [(zero? flush-disabled)
+        ;; In case a display got lost earlier:
+        (tellv cocoa display)
+        (thunk)]
+       [else
+        (atomically
+         (dynamic-wind
+          (lambda ()
+            (when (zero? flush-disable-disabled)
+              (tellv cocoa setAutodisplay: #:type _BOOL #t)
+              (tellv cocoa enableFlushWindow))
+            (tellv cocoa display)
+            (set! flush-disable-disabled (add1 flush-disable-disabled)))
+          thunk
+          (lambda ()
+            (set! flush-disable-disabled (sub1 flush-disable-disabled))
+            (when (zero? flush-disable-disabled)
+              (unless (zero? flush-disabled)
+                (tellv cocoa setAutodisplay: #:type _BOOL #f)
+                (tellv cocoa disableFlushWindow))))))]))
 
     (define/public (force-window-focus)
       (let ([next (get-app-front-window)])
@@ -575,25 +609,27 @@
       (unless (and (equal? x -1) (equal? y -1))
         (internal-move x y))
       (let ([f (tell #:type _NSRect cocoa frame)])
-        (tellv cocoa setFrame: 
-               #:type _NSRect (make-NSRect 
-                               (make-NSPoint (if (and is-a-dialog?
-                                                      (let ([p (get-parent)])
-                                                        (and p
-                                                             (eq? this (send p get-sheet)))))
-                                                 ;; need to re-center sheet:
-                                                 (let* ([p (get-parent)]
-                                                        [px (send p get-x)]
-                                                        [pw (send p get-width)])
-                                                   (+ px (/ (- pw w) 2)))
-                                                 ;; keep current x position:
-                                                 (NSPoint-x (NSRect-origin f)))
-                                             ;; keep current y position:
-                                             (- (NSPoint-y (NSRect-origin f))
-                                                (- h
-                                                   (NSSize-height (NSRect-size f)))))
-                               (make-NSSize w h))
-               display: #:type _BOOL #t)))
+        (call-with-refreshable
+         (lambda ()
+           (tellv cocoa setFrame:
+                  #:type _NSRect (make-NSRect
+                                  (make-NSPoint (if (and is-a-dialog?
+                                                         (let ([p (get-parent)])
+                                                           (and p
+                                                                (eq? this (send p get-sheet)))))
+                                                    ;; need to re-center sheet:
+                                                    (let* ([p (get-parent)]
+                                                           [px (send p get-x)]
+                                                           [pw (send p get-width)])
+                                                      (+ px (/ (- pw w) 2)))
+                                                    ;; keep current x position:
+                                                    (NSPoint-x (NSRect-origin f)))
+                                                ;; keep current y position:
+                                                (- (NSPoint-y (NSRect-origin f))
+                                                   (- h
+                                                      (NSSize-height (NSRect-size f)))))
+                                  (make-NSSize w h))
+                  display: #:type _BOOL #t)))))
     (define/override (internal-move x y)
       (let ([x (if (not x) (get-x) x)]
             [y (if (not y) (get-y) y)])

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

@@ -10,7 +10,8 @@
               scheme_remove_gc_callback
               make-gc-action-desc
               make-gl-install
-              make-gl-uninstall))
+              make-gl-uninstall
+              do-gl-action))
 
 ;; ----------------------------------------
 ;; 10.10 and earlier: change window opacity
@@ -74,6 +75,9 @@
 (define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void))
 (define-gl glClear (_fun _GLbitfield -> _void))
 
+(define-gl glCallList (_fun _GLint -> _void))
+(define-gl glFlush (_fun -> _void))
+
 (define-gl glClear-pointer _fpointer
   #:c-id glClear)
 (define-gl glCallList-pointer _fpointer
@@ -112,12 +116,14 @@
   (define size (* w h 4))
   (define size-4 (- size 4))
   (define rgba (make-bytes size))
-  (for ([i (in-range 0 size 4)])
-    (define j (- size-4 i))
-    (bytes-set! rgba (+ i 3) (bytes-ref argb j))
-    (bytes-set! rgba i (bytes-ref argb (+ j 1)))
-    (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2)))
-    (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3))))
+  (for ([x (in-range w)])
+    (for ([y (in-range h)])
+      (define i (* (+ x (* w y)) 4))
+      (define j (* (+ x (* w (- h y 1))) 4))
+      (bytes-set! rgba (+ i 3) (bytes-ref argb j))
+      (bytes-set! rgba i (bytes-ref argb (+ j 1)))
+      (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2)))
+      (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3)))))
   
   (define tex (glGenTexture))
   
@@ -172,6 +178,8 @@
       (tellv old-gl makeCurrentContext)
       (tellv NSOpenGLContext clearCurrentContext))
   
+  ;; The shape of this vector is parsed back out by
+  ;; `do-gl-action`, below:
   (vector
    (vector 'ptr_ptr->save
            msg-send-proc
@@ -237,3 +245,18 @@
    (vector 'save!_ptr->void
            msg-send-proc
            (selector makeCurrentContext))))
+
+(define (do-gl-action vec)
+  (when (= 8 (vector-length vec))
+    (define gl (vector-ref (vector-ref vec 1) 2))
+    (define list-id (vector-ref (vector-ref vec 3) 2))
+
+    (define old-ctx (tell NSOpenGLContext currentContext))
+    (tellv gl makeCurrentContext)
+    (glClear GL_COLOR_BUFFER_BIT)
+    (glCallList list-id)
+    (glFlush)
+    (tellv gl flushBuffer)
+    (tellv NSOpenGLContext clearCurrentContext)
+    (when old-ctx
+      (tellv old-ctx makeCurrentContext))))

gui-lib/mred/private/wx/cocoa/list-box.rkt

@@ -282,7 +282,7 @@
   (define/public (append-column title)
     (atomically
      (let ([col (as-objc-allocation
-                 (tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))])
+                 (tell (tell NSTableColumn alloc) initWithIdentifier: #:type _NSString title))])
        (tellv content-cocoa addTableColumn: col)
        (tellv (tell col headerCell) setStringValue: #:type _NSString title)
        (set! column-cocoas (append column-cocoas (list col)))

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

@@ -85,6 +85,7 @@
    get-color-from-user
    special-option-key
    special-control-key
+   any-control+alt-is-altgr
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap

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

@@ -65,6 +65,7 @@
  play-sound
  file-creator-and-type
  file-selector
+ any-control+alt-is-altgr
  key-symbol-to-menu-key
  needs-grow-box-spacer?
  get-current-mouse-state

gui-lib/mred/private/wx/cocoa/tab-panel.rkt

@@ -19,15 +19,33 @@
 
 (define-runtime-path psm-tab-bar-dir
   '(so "PSMTabBarControl.framework"))
+(define-runtime-path mm-tab-bar-dir
+  ;; This directory will not exist for platforms other than x86_64:
+  '(so "MMTabBarView.framework"))
 
-;; Load PSMTabBarControl:
-(void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl")))
+(define use-mm?
+  (and (version-10.10-or-later?)
+       64-bit?
+       (directory-exists? mm-tab-bar-dir)))
+
+;; Load MMTabBarView or PSMTabBarControl:
+(if use-mm?
+    (void (ffi-lib (build-path mm-tab-bar-dir "MMTabBarView")))
+    (void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))))
 (define NSNoTabsNoBorder 6)
 
 (define NSDefaultControlTint 0)
 (define NSClearControlTint 7)
 
-(import-class NSView NSTabView NSTabViewItem PSMTabBarControl)
+(import-class NSView NSTabView NSTabViewItem)
+(define TabBarControl
+  (if use-mm?
+      (let ()
+        (import-class MMTabBarView)
+        MMTabBarView)
+      (let ()
+        (import-class PSMTabBarControl)
+        PSMTabBarControl)))
 (import-protocol NSTabViewDelegate)
 
 (define NSOrderedAscending -1)
@@ -49,8 +67,26 @@
         (when (and wx (send wx callbacks-enabled?))
           (queue-window*-event wxb (lambda (wx) (send wx do-callback)))))))
 
-(define-objc-class RacketPSMTabBarControl PSMTabBarControl
-  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
+;; The MMTabBarView widget doesn't support disabling, so we have to
+;; implement it. Also, we need to override a method to disable (for now)
+;; reordering tabs.
+(define-objc-mixin (EnableMixin Superclass)
+  [wxb]
+  (-a _id (hitTest: [_NSPoint pt])
+      (let ([wx (->wx wxb)])
+        (if (and wx
+                 (not (send wx is-enabled-to-root?)))
+            #f
+            (super-tell hitTest: #:type _NSPoint pt))))
+  (-a _BOOL (shouldStartDraggingAttachedTabBarButton: b withMouseDownEvent: evt)
+      #f))
+
+;; A no-op mixin instead of `EnableMixin` for PSMTabBarControl:
+(define-objc-mixin (EmptyMixin Superclass)
+  [wxb])
+
+(define-objc-class RacketPSMTabBarControl TabBarControl
+  #:mixins (FocusResponder KeyMouseResponder CursorDisplayer (if use-mm? EnableMixin EmptyMixin))
   [wxb]
   (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
       (super-tell #:type _void tabView: cocoa didSelectTabViewItem: item-cocoa)
@@ -83,8 +119,10 @@
            (tellv tabv-cocoa setDelegate: i)
            (tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder)
            (tellv i setTabView: tabv-cocoa)
-           (tellv i setStyleNamed: #:type _NSString "Aqua")
-           ;;(tellv i setSizeCellsToFit: #:type _BOOL #t)
+           (tellv i setStyleNamed: #:type _NSString (if use-mm? "Yosemite" "Aqua"))
+           ;; (tellv i setSizeCellsToFit: #:type _BOOL #t)
+           (when use-mm?
+             (tellv i setResizeTabsToFitTotalWidth: #:type _BOOL #t))
            (tellv i setDisableTabClose: #:type _BOOL #t)
            i)))
 
@@ -204,7 +242,8 @@
       (tellv tabv-cocoa setControlTint: #:type _int
              (if on? NSDefaultControlTint NSClearControlTint))
       (when control-cocoa
-        (tellv control-cocoa setEnabled: #:type _BOOL on?))))
+        (unless use-mm?
+          (tellv control-cocoa setEnabled: #:type _BOOL on?)))))
 
   (define/override (can-accept-focus?)
     (and (not control-cocoa)

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

@@ -21,8 +21,6 @@
 
 (define _OSStatus _sint32)
 
-(define 64-bit? (= (ctype-sizeof _long) 8))
-
 (define _CGFloat (make-ctype (if 64-bit? _double _float)
                              (lambda (v) (if (and (number? v)
                                                   (exact? v))

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

@@ -21,6 +21,7 @@
               clean-menu-label
               ->wxb
               ->wx
+              64-bit?
               old-cocoa?
               version-10.6-or-later?
               version-10.7-or-later?
@@ -74,6 +75,8 @@
   (and wxb
        (weak-box-value wxb)))
 
+(define 64-bit? (= (ctype-sizeof _long) 8))
+
 (define-appkit NSAppKitVersionNumber _double)
 
 (define old-cocoa? 

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

@@ -621,11 +621,13 @@
 
     (define enabled? #t)
     (define/public (is-enabled-to-root?)
-      (and (is-window-enabled?) (is-parent-enabled-to-root?)))
+      (and (is-window-enabled?/raw) (is-parent-enabled-to-root?)))
     (define/public (is-parent-enabled-to-root?)
       (send parent is-enabled-to-root?))
-    (define/public (is-window-enabled?)
+    (define/public (is-window-enabled?/raw)
       enabled?)
+    (define/public (is-window-enabled?)
+      (is-window-enabled?/raw))
     (define/public (enable on?)
       (atomically
        (set! enabled? on?)
@@ -761,7 +763,16 @@
                  (is-enabled-to-root?))
         (let ([w (tell cocoa window)])
           (when w
-            (tellv w makeFirstResponder: (get-cocoa-focus))))))
+            (tellv w makeFirstResponder: (get-cocoa-focus))
+            ;; Within a floating frame or when potentially taking
+            ;; focus from a floating frame, also make the frame the
+            ;; key window:
+            (let ([top (get-wx-window)])
+              (when (and (or (send top floating?)
+                             (tell #:type _BOOL w isMainWindow))
+                         (tell #:type _bool w isVisible))
+                (tellv w makeKeyAndOrderFront: #f)))))))
+                
     (define/public (on-set-focus) (void))
     (define/public (on-kill-focus) (void))
 

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

@@ -43,6 +43,13 @@
   (class (record-dc-mixin (dc-mixin bitmap-dc-backend%))
     (init transparent?)
 
+    (define retained-cr #f)
+    (define retained-counter 0)
+    (define needs-flush? #f)
+    (define nada? #t)
+    (define flush-suspends 0)
+    (define req #f)
+
     (inherit internal-get-bitmap
              internal-set-bitmap
              reset-cr
@@ -67,11 +74,6 @@
     (define/public (queue-backing-flush)
       (void))
 
-    (define retained-cr #f)
-    (define retained-counter 0)
-    (define needs-flush? #f)
-    (define nada? #t)
-
     ;; called with a procedure that is applied to a bitmap;
     ;;  returns #f if there's nothing to flush
     (define/public (on-backing-flush proc)
@@ -96,8 +98,9 @@
             (set! retained-cr #f)
             (internal-set-bitmap #f #t)
             (super release-cr retained-cr)
-            (proc bm)
-            (release-backing-bitmap bm)))))
+            (when bm
+              (proc bm)
+              (release-backing-bitmap bm))))))
 
     (define/public (start-backing-retained)
       (as-entry
@@ -133,6 +136,9 @@
       (when (zero? flush-suspends)
         (queue-backing-flush)))
 
+    (define/override (release-unchanged-cr cr)
+      (void))
+
     (define/override (erase)
       (super erase)
       (when (= (get-clear-operator)
@@ -143,9 +149,6 @@
       (super erase)
       (set! nada? #t))
 
-    (define flush-suspends 0)
-    (define req #f)
-
     (define/public (request-delay) (void))
     (define/public (cancel-delay req) (void))
 

gui-lib/mred/private/wx/common/default-procs.rkt

@@ -3,6 +3,7 @@
          racket/draw/private/color)
 (provide special-control-key
          special-option-key
+         any-control+alt-is-altgr
          file-creator-and-type
          get-panel-background
          fill-private-color)
@@ -19,6 +20,12 @@
    [() special-option-key?]
    [(on?) (set! special-option-key? (and on? #t))]))
 
+(define any-control+alt-is-altgr? #f)
+(define any-control+alt-is-altgr
+  (case-lambda
+   [() any-control+alt-is-altgr?]
+   [(on?) (set! any-control+alt-is-altgr? (and on? #t))]))
+
 (define file-creator-and-type
   (case-lambda
    [(path cr ty) (void)]

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

@@ -469,7 +469,8 @@
                                                     GDK_POINTER_MOTION_MASK
                                                     GDK_FOCUS_CHANGE_MASK
                                                     GDK_ENTER_NOTIFY_MASK
-                                                    GDK_LEAVE_NOTIFY_MASK))
+                                                    GDK_LEAVE_NOTIFY_MASK
+                                                    GDK_SCROLL_MASK))
      (unless (or (memq 'no-focus style)
                  (is-panel?))
        (gtk_widget_set_can_focus client-gtk #t))

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

@@ -131,9 +131,9 @@
               (GdkEventWindowState-new_window_state evt))))
     #f))
 
-(define-runtime-path plt-16x16-file '(lib "icons/plt-16x16.png"))
-(define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png"))
-(define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png"))
+(define-runtime-path plt-16x16-file '(lib "icons/plt-icon-16x16.png"))
+(define-runtime-path plt-32x32-file '(lib "icons/plt-icon-32x32.png"))
+(define-runtime-path plt-48x48-file '(lib "icons/plt-icon-48x48.png"))
 
 (define icon-pixbufs+glist
   (delay

gui-lib/mred/private/wx/gtk/gl-context.rkt

@@ -144,6 +144,9 @@
 (define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay))
 (define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
 
+(define-glx glXSwapIntervalEXT (_fun _Display _XID _int -> _void)
+  #:fail (lambda () void))
+
 ;; ===================================================================================================
 ;; GLX versions and extensions queries
 
@@ -247,9 +250,10 @@
     (dynamic-wind
      (λ ()
        (set! old-handler
-	     (XSetErrorHandler (cast flag-x-error-handler
-				     (_fun #:atomic? #t _Display _XErrorEvent -> _int)
-				     _fpointer))))
+             (XSetErrorHandler
+              (cast flag-x-error-handler
+                    (_fun #:atomic? #t _Display _XErrorEvent -> _int)
+                    _fpointer))))
      (λ ()
        (set! create-context-error? #f)
        (glXCreateNewContext xdisplay cfg GLX_RGBA_TYPE share-gl #t))
@@ -290,7 +294,11 @@
   (define gl
     (dynamic-wind
      (λ ()
-       (set! old-handler (XSetErrorHandler flag-x-error-handler)))
+       (set! old-handler
+             (XSetErrorHandler
+              (cast flag-x-error-handler
+                    (_fun #:atomic? #t _Display _XErrorEvent -> _int)
+                    _fpointer))))
      (λ ()
        (set! create-context-error? #f)
        (glXCreateContextAttribsARB xdisplay cfg share-gl #t context-attribs))
@@ -419,6 +427,9 @@
      ;; The above will return a direct rendering context when it can
      ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with
      ;; proprietary extensions (NVIDIA's drivers sometimes do this)
+
+     (when (and widget (send conf get-sync-swap))
+       (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1))
      
      ;; Now wrap the GLX context in a gl-context%
      (cond

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

@@ -9,7 +9,11 @@
 (provide (protect-out (all-defined-out)))
 
 (define-runtime-lib gio-lib
-  [(unix) (ffi-lib "libgio-2.0" '("0" ""))]
+  [(unix) (ffi-lib "libgio-2.0" '("0" "")
+                   ;; For old glib, libgio isn't separate;
+                   ;; try to find bindings in already-loaded
+                   ;; libraries:
+                   #:fail (lambda () #f))]
   [(macosx)
    (ffi-lib "libgio-2.0.0.dylib")]
   [(windows) 

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

@@ -8,7 +8,9 @@
 (define (get-gdk3-lib)
   (ffi-lib "libgdk-3" '("0" "") #:fail (lambda () #f)))
 (define (get-gtk3-lib)
-  (ffi-lib "libgtk-3" '("0" "") #:fail (lambda () #f)))
+  ;; Open in "global" mode so that gtk_print_operation_run()
+  ;; can find the printer dialog using _g_module_symbol():
+  (ffi-lib "libgtk-3" '("0" "") #:global? #t #:fail (lambda () #f)))
 
 (define gtk3?
   (and (not (getenv "PLT_GTK2"))

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

@@ -139,8 +139,6 @@
       (gtk_fixed_move (get-container-gtk) child-gtk (->screen x) (->screen y))
       (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))))
 
-(define-gdk gdk_window_has_native (_fun _GdkWindow -> _gboolean))
-
 (define panel%
   (class (panel-container-mixin (panel-mixin window%))
     (init parent

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

@@ -86,6 +86,7 @@
    get-color-from-user
    special-option-key
    special-control-key
+   any-control+alt-is-altgr
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap

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

@@ -56,6 +56,7 @@
  file-creator-and-type
  special-control-key
  special-option-key
+ any-control+alt-is-altgr
  get-panel-background
  fill-private-color
  get-color-from-user

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

@@ -67,6 +67,7 @@
 (define-gtk gtk_widget_get_style (_fun  _GtkWidget -> _GtkStyle-pointer))
 (define-gtk gtk_rc_get_style (_fun  _GtkWidget -> _GtkStyle-pointer))
 (define-gtk gtk_text_view_new (_fun -> _GtkWidget))
+(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void))
 
 (define the-text-style
   (let ([w (gtk_text_view_new)])
@@ -74,8 +75,7 @@
       (g_object_ref style)
       (begin0
        style
-       (g_object_ref_sink w)
-       (g_object_unref w)))))
+       (gtk_widget_destroy w)))))
 
 (define (extract-color-values c)
   (define (s v) (arithmetic-shift v -8))

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

@@ -10,6 +10,9 @@
 (provide 
  (protect-out do-single-instance))
 
+;; ----------------------------------------
+;; Old-style -singleInstance support lith libunqiue
+
 (define unique-lib-name "libunique-1.0")
 
 (define unique-lib
@@ -56,14 +59,94 @@
 					    (exn-message exn))))])
 	(let* ([p (open-input-bytes d)]
 	       [vec (read p)])
-	  (for-each
-	   queue-file-event
-	   (map (lambda (s) (if (bytes? s)
-                                (bytes->path s)
-                                (string->path s)))
-                (vector->list vec))))))
+	  (handle-argv vec))))
     UNIQUE_RESPONSE_OK))
 
+(define (send-command-line app)
+  (let ([msg (unique_message_data_new)]
+        [b (let ([o (open-output-bytes)])
+             (write (for/vector ([p (in-vector (current-command-line-arguments))])
+                      (define cp (path->complete-path p))
+                      (define s (path->string cp))
+                      (if (equal? cp (string->path s))
+                          s
+                          ;; can't represent as string; use bytes
+                          (path->bytes cp)))
+                    o)
+             (get-output-bytes o))])
+    (unique_message_data_set msg b (bytes-length b))
+    (unique_app_send_message app 42 msg)))
+
+(define (do-single-instance/libunique)
+  (let ([app (unique_app_new (build-app-name) #f)])
+    (when app
+      (unique_app_add_command app "startup" 42)
+      (when (unique_app_is_running app)
+        (when (= (send-command-line app)
+                 UNIQUE_RESPONSE_OK)
+          (exit 0)))
+      (void (connect-message-received app)))))
+
+;; ----------------------------------------
+;; New-style -singleInstance support with Gtk
+
+(define _GtkApplication _GtkWidget) ; (_cpointer/null 'GtkApplication)
+(define _GApplicationCommandLine (_cpointer 'GApplicationCommandLine))
+
+(define-gtk gtk_application_new (_fun _string _int -> _GtkApplication)
+  #:fail (lambda () #f))
+
+(define-gdk g_application_get_is_remote (_fun _GtkApplication -> _gboolean)
+  #:make-fail make-not-available)
+(define-gdk g_application_run (_fun _GtkApplication _int (_vector i _string) -> _gboolean)
+  #:make-fail make-not-available)
+(define-gdk g_application_command_line_get_arguments
+  (_fun _GApplicationCommandLine (n : (_ptr o _int)) -> (p : _pointer) -> (values p n))
+  #:make-fail make-not-available)
+(define-gdk g_strfreev (_fun _pointer -> _void)
+  #:make-fail make-not-available)
+
+(define-signal-handler connect-activate "activate"
+  (_fun _GtkApplication -> _void)
+  (lambda (app)
+    (void)))
+
+(define-signal-handler connect-command-line "command-line"
+  (_fun _GtkApplication _GApplicationCommandLine -> _void)
+  (lambda (app cmdline)
+    (define-values (args n) (g_application_command_line_get_arguments cmdline))
+    (define argv (cast args _pointer (_vector o _string n)))
+    (g_strfreev args)
+    (handle-argv argv)))
+
+(define APPLICATION_HANDLES_COMMAND_LINE 8)
+
+(define (do-single-instance/gtk)
+  (define app (gtk_application_new (build-app-name) APPLICATION_HANDLES_COMMAND_LINE))
+  (when app
+    (define args (for/vector ([i (current-command-line-arguments)])
+		   (path->string (path->complete-path i))))
+    (g_application_run app (vector-length args) args)
+    (when (g_application_get_is_remote app)
+      (exit 0))
+    (connect-activate app)
+    (connect-command-line app)))
+
+;; ----------------------------------------
+
+(define (do-single-instance)
+  (if gtk_application_new
+      (do-single-instance/gtk)
+      (do-single-instance/libunique)))
+
+(define (handle-argv vec)
+  (for-each
+   queue-file-event
+   (map (lambda (s) (if (bytes? s)
+			(bytes->path s)
+			(string->path s)))
+	(vector->list vec))))
+
 (define-mz gethostname (_fun _pointer _long -> _int)
   #:fail (lambda () #f))
 
@@ -87,28 +170,3 @@
 
 (define (encode s)
   (regexp-replace* #rx"=|\r\n" (base64-encode (string->bytes/utf-8 s)) ""))
-
-(define (send-command-line app)
-  (let ([msg (unique_message_data_new)]
-        [b (let ([o (open-output-bytes)])
-             (write (for/vector ([p (in-vector (current-command-line-arguments))])
-                      (define cp (path->complete-path p))
-                      (define s (path->string cp))
-                      (if (equal? cp (string->path s))
-                          s
-                          ;; can't represent as string; use bytes
-                          (path->bytes cp)))
-                    o)
-             (get-output-bytes o))])
-    (unique_message_data_set msg b (bytes-length b))
-    (unique_app_send_message app 42 msg)))
-
-(define (do-single-instance)
-  (let ([app (unique_app_new (build-app-name) #f)])
-    (when app
-      (unique_app_add_command app "startup" 42)
-      (when (unique_app_is_running app)
-        (when (= (send-command-line app)
-                 UNIQUE_RESPONSE_OK)
-          (exit 0)))
-      (void (connect-message-received app)))))

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

@@ -269,28 +269,30 @@
                                 (or
                                  (map-key-code kv)
                                  (integer->char (gdk_keyval_to_unicode kv))))]
-                [key-code (if scroll?
-                              (let ([dir (GdkEventScroll-direction event)])
+                [key-code (cond
+                           [scroll?
+                            (let ([dir (GdkEventScroll-direction event)])
+                              (cond
+                               [(= dir GDK_SCROLL_UP) 'wheel-up]
+                               [(= dir GDK_SCROLL_DOWN) 'wheel-down]
+                               [(= dir GDK_SCROLL_LEFT) 'wheel-left]
+                               [(= dir GDK_SCROLL_RIGHT) 'wheel-right]
+                               [(= dir GDK_SCROLL_SMOOTH)
+                                (define-values (dx dy) (gdk_event_get_scroll_deltas event))
                                 (cond
-                                 [(= dir GDK_SCROLL_UP) 'wheel-up]
-                                 [(= dir GDK_SCROLL_DOWN) 'wheel-down]
-                                 [(= dir GDK_SCROLL_LEFT) 'wheel-left]
-                                 [(= dir GDK_SCROLL_RIGHT) 'wheel-right]
-				 [(= dir GDK_SCROLL_SMOOTH)
-				  (define-values (dx dy) (gdk_event_get_scroll_deltas event))
-				  (cond
-				   [(positive? dy) 'wheel-down]
-				   [(negative? dy) 'wheel-up]
-				   [(positive? dx) 'wheel-right]
-				   [(negative? dx) 'wheel-left]
-				   [else #f])]
-				 [else #f]))
-                              (keyval->code (GdkEventKey-keyval event)))]
+                                 [(positive? dy) 'wheel-down]
+                                 [(negative? dy) 'wheel-up]
+                                 [(positive? dx) 'wheel-right]
+                                 [(negative? dx) 'wheel-left]
+                                 [else #f])]
+                               [else #f]))]
+                           [(and (string? im-str)
+                                 (= 1 (string-length im-str)))
+                            (string-ref im-str 0)]
+                           [else
+                            (keyval->code (GdkEventKey-keyval event))])]
                 [k (new key-event%
-                        [key-code (if (and (string? im-str)
-                                           (= 1 (string-length im-str)))
-                                      (string-ref im-str 0)
-                                      key-code)]
+                        [key-code key-code]
                         [shift-down (bit? modifiers GDK_SHIFT_MASK)]
                         [control-down (bit? modifiers GDK_CONTROL_MASK)]
                         [meta-down (bit? modifiers GDK_MOD1_MASK)]
@@ -704,7 +706,15 @@
       (send parent in-floating?))
 
     (define/public (set-focus)
-      (gtk_widget_grab_focus (get-client-gtk)))
+      (define gtk (get-client-gtk))
+      (gtk_widget_grab_focus gtk)
+      ;; Force focus to or away from a floating window:
+      (cond
+       [(and (in-floating?)
+	     (is-shown-to-root?))
+	(gdk_keyboard_grab (widget-window gtk) #t 0)]
+       [else
+	(gdk_keyboard_ungrab 0)]))
 
     (define cursor-handle #f)
     (define/public (set-cursor v)

gui-lib/mred/private/wx/platform.rkt

@@ -1,13 +1,16 @@
 #lang racket/base
 (require racket/runtime-path 
-         (for-syntax racket/base))
+         setup/cross-system
+         (for-syntax racket/base
+                     setup/cross-system))
 (provide 
  (protect-out (all-defined-out)))
 
 (define-runtime-module-path-index platform-lib
+  #:runtime?-id runtime?
   (let ([gtk-lib
          '(lib "mred/private/wx/gtk/platform.rkt")])
-    (case (system-type)
+    (case (if runtime? (system-type) (cross-system-type))
       [(windows) (if (getenv "PLT_WIN_GTK")
                      gtk-lib
                      '(lib "mred/private/wx/win32/platform.rkt"))]
@@ -72,6 +75,7 @@
                 get-color-from-user
                 special-option-key
                 special-control-key
+                any-control+alt-is-altgr
                 get-highlight-background-color
                 get-highlight-text-color
                 make-screen-bitmap

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

@@ -401,15 +401,19 @@
      (define h-scroll-visible? hscroll?)
      (define v-scroll-visible? vscroll?)
      (define/public (show-scrollbars h? v?)
-       (when hscroll?
-         (atomically
-          (set! h-scroll-visible? (and h? #t))
-          (ShowScrollBar canvas-hwnd SB_HORZ h?)))
-       (when vscroll?
-         (atomically
-          (set! v-scroll-visible? (and v? #t))
-          (ShowScrollBar canvas-hwnd SB_VERT v?)))
-       (reset-dc))
+       (unless (and (equal? h-scroll-visible?
+                            (and h? hscroll? #t))
+                    (equal? v-scroll-visible?
+                            (and v? vscroll? #t)))
+         (when hscroll?
+           (atomically
+            (set! h-scroll-visible? (and h? #t))
+            (ShowScrollBar canvas-hwnd SB_HORZ h?)))
+         (when vscroll?
+           (atomically
+            (set! v-scroll-visible? (and v? #t))
+            (ShowScrollBar canvas-hwnd SB_VERT v?)))
+         (reset-dc)))
 
      (define/override (do-set-scrollbars h-step v-step
                                          h-len v-len

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

@@ -428,9 +428,18 @@
       (set! focus-window-path #f)))
   (define/override (set-top-focus win win-path child-hwnd)
     (set! focus-window-path (cons this win-path))
-    (when (ptr-equal? hwnd (GetActiveWindow))
+    (define active-hwnd (GetActiveWindow))
+    (when (or (ptr-equal? hwnd active-hwnd)
+	      (and (or float-without-caption?
+		       (let ([wx (any-hwnd->wx active-hwnd)])
+			 (and wx
+			      (send wx is-floating?))))
+		   (is-shown?)))
       (void (SetFocus child-hwnd))))
 
+  (define/public (is-floating?)
+    float-without-caption?)
+
   (define/private (set-frame-focus)
     (let ([p focus-window-path])
       (when (pair? p)

gui-lib/mred/private/wx/win32/gl-context.rkt

@@ -74,6 +74,9 @@
 (define looked-for-createcontextattribs? #f)
 (define wglCreateContextAttribsARB #f)
 
+(define looked-for-wglswapinternalext? #f)
+(define wglSwapIntervalEXT #f)
+
 ;; ----------------------------------------
 
 (define gl-context% 
@@ -176,7 +179,21 @@
                                  (wglCreateContextAttribsARB hdc context-handle (vector 0))
                                  (wglCreateContext hdc))])
 		  (and hglrc
-		       (new gl-context% [hglrc hglrc] [hdc hdc]))))))))
+		       (begin
+			 (when (send config get-sync-swap)
+			   (call-with-context
+			    hdc
+			    hglrc
+			    (lambda ()
+			      (unless looked-for-wglswapinternalext?
+				(set! wglSwapIntervalEXT
+				      (let ([f (wglGetProcAddress "wglSwapIntervalEXT")])
+					(and f
+					     (function-ptr f (_wfun _int -> _void)))))
+				(set! looked-for-wglswapinternalext? #t))
+			      (when wglSwapIntervalEXT
+				(wglSwapIntervalEXT 1)))))
+			 (new gl-context% [hglrc hglrc] [hdc hdc])))))))))
 
 (define (with-dummy-context config thunk)
   ;; To create a gl context, we need a separate window 

gui-lib/mred/private/wx/win32/key.rkt

@@ -10,25 +10,47 @@
  (protect-out maybe-make-key-event
               generates-key-event?
 	      reset-key-mapping
-              key-symbol-to-menu-key))
+              key-symbol-to-menu-key
+              any-control+alt-is-altgr))
 
 (define-user32 GetKeyState (_wfun _int -> _SHORT))
 (define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT))
 (define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT))
+(define-user32 ToUnicode (_wfun _UINT _UINT _pointer _pointer _int _UINT -> _int))
+(define-user32 GetKeyboardState (_wfun _pointer -> _BOOL))
 
+(define control+alt-always-as-altgr? #f)
+(define any-control+alt-is-altgr
+  (case-lambda
+   [() control+alt-always-as-altgr?]
+   [(on?) (set! control+alt-always-as-altgr? (and on? #t))]))
+
+;; Back-door result from `key-mapped?` via `maybe-make-key-event`:
+(define no-translate? #f)
+
+;; Called to determine whether a WM_KEYDOWN event should
+;; be passed to TranslateEvent() to get a WM_CHAR event.
+;; If the WM_KEYDOWN event itself will translate to a
+;; visible key event, then don't use TranslateEvent().
 (define (generates-key-event? msg)
   (let ([message (MSG-message msg)])
     (and (or (eq? message WM_KEYDOWN)
              (eq? message WM_SYSKEYDOWN)
              (eq? message WM_KEYUP)
              (eq? message WM_SYSKEYUP))
-         (maybe-make-key-event #t 
-                               (MSG-wParam msg)
-                               (MSG-lParam msg)
-                               #f
-                               (or (= message WM_KEYUP)
-                                   (= message WM_SYSKEYUP))
-                               (MSG-hwnd msg)))))
+         (or (maybe-make-key-event #t 
+				   (MSG-wParam msg)
+				   (MSG-lParam msg)
+				   #f
+				   (or (= message WM_KEYUP)
+				       (= message WM_SYSKEYUP))
+				   (MSG-hwnd msg))
+	     ;; If ToUnicode() was used for checking, claim that
+	     ;; an event will be generated so that TranslateEvent()
+	     ;; is not used.
+	     (begin0
+	      no-translate?
+	      (set! no-translate? #f))))))
 
 (define (THE_SCAN_CODE lParam)
   (bitwise-and (arithmetic-shift lParam -16) #x1FF))
@@ -53,7 +75,8 @@
 		 (VkKeyScanW (char->integer i)))))
 	other-key-codes)))
 (define (reset-key-mapping)
-  (set! other-key-codes #f))
+  (set! other-key-codes #f)
+  (set! mapped-keys (make-hash)))
 (define (other-orig j)
   (char->integer (string-ref find_shift_alts j)))
 
@@ -184,9 +207,14 @@
                       ;; wParam is a virtual key code
                       (let ([id (hash-ref win32->symbol wParam #f)]
                             [override-mapping? (and control-down?
-						    ;; not AltGR:
-						    (not (and lcontrol-down?
-							      ralt-down?)))]
+						    ;; not AltGR or no mapping:
+						    (or (not alt-down?)
+							(not (or control+alt-always-as-altgr?
+								 (and lcontrol-down?
+								      ralt-down?)))
+							(not (key-mapped? wParam 
+									  (THE_SCAN_CODE lParam)
+									  just-check?))))]
                             [try-generate-release
                              (lambda ()
                                (let ([sc (THE_SCAN_CODE lParam)])
@@ -264,8 +292,9 @@
                               [caps-down caps-down?]
 			      [control+meta-is-altgr (and control-down?
                                                           alt-down?
-							  (not rcontrol-down?)
-							  (not lalt-down?))])]
+							  (or control+alt-always-as-altgr?
+							      (and (not rcontrol-down?)
+								   (not lalt-down?))))])]
 		      [as-key (lambda (v)
 				(if (integer? v) (integer->char v) v))])
 		 (when is-up?
@@ -341,3 +370,29 @@
          (subtract . Subtract)
          (numpad-enter . |Numpad Enter|)
          (numpad6 . |Numpad 6|)))
+
+;; The `key-mapped?` function is used to predict whether an
+;; AltGr combination will produce a key; if not, a key
+;; event can be synthesized (like control combinations)
+(define keys-state (make-bytes 256))
+(define unicode-result (make-bytes 20))
+(define mapped-keys (make-hash))
+(define (key-mapped? vk sc just-check?)
+  (define key (vector vk sc))
+  (hash-ref mapped-keys
+	    key
+	    (lambda ()
+	      (cond
+	       [just-check?
+		;; In checking mode, we can use ToUnicode():
+		(GetKeyboardState keys-state)
+		(define n (ToUnicode vk sc keys-state unicode-result 10 0))
+		(when (= n -1)
+                  ;; For a dead char, ToUnicode() seems to have the effect
+		  ;; of TranslateEvent(), so avoid the latter.
+		  (set! no-translate? #t))
+		(define mapped? (not (zero? n)))
+		;; Record what we learned for use by non-checking mode:
+		(hash-set! mapped-keys key mapped?)
+		mapped?]
+	       [else #f]))))

gui-lib/mred/private/wx/win32/platform.rkt

@@ -23,6 +23,7 @@
          "slider.rkt"
          "tab-panel.rkt"
          "window.rkt"
+         "key.rkt"
          "procs.rkt")
 (provide (protect-out platform-values))
 
@@ -86,6 +87,7 @@
    get-color-from-user
    special-option-key
    special-control-key
+   any-control+alt-is-altgr
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap

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

@@ -12,7 +12,8 @@
          "dc.rkt"
          "printer-dc.rkt"
          (except-in "../common/default-procs.rkt"
-                    get-panel-background)
+                    get-panel-background
+                    any-control+alt-is-altgr)
          "filedialog.rkt"
          "colordialog.rkt"
          "sound.rkt"
@@ -136,7 +137,7 @@
         (list sym)
         null))
   (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON))))
-  (values (make-object point% (POINT-x p) (POINT-y p))
+  (values (make-object point% (->normal (POINT-x p)) (->normal (POINT-y p)))
           (append
            (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left)
            (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right)

gui-lib/mred/private/wx/win32/sound.rkt

@@ -1,7 +1,9 @@
 #lang racket/base
 (require ffi/unsafe
+	 ffi/winapi
+	 ffi/unsafe/custodian
+	 ffi/unsafe/atomic
          racket/class
-	 "../../lock.rkt"
          "utils.rkt"
          "types.rkt"
          "const.rkt")
@@ -9,28 +11,67 @@
 (provide
  (protect-out play-sound))
 
-(define-winmm PlaySoundW (_wfun _string/utf-16 _pointer _DWORD -> _BOOL))
+(define BUFFER-SIZE 512)
+(define BUFFER-BYTES-SIZE (* 2 BUFFER-SIZE))
 
-(define SND_SYNC   #x0000)
-(define SND_ASYNC  #x0001)
-(define SND_NOSTOP #x0010)
+(define-winmm mciGetErrorStringW
+  (_fun _int
+	[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
+	[_int = BUFFER-SIZE]
+	-> [ret : _bool]
+	-> (and ret (cast buf _pointer _string/utf-16))))
 
-(define previous-done-sema #f)
+(define-winmm mciSendStringW
+  (_fun _string/utf-16 [_pointer = #f] [_int = 0] [_pointer = #f]
+	-> [ret : _int]
+	-> (if (zero? ret)
+	       (void)
+	       (error 'mciSendStringW "~a" (mciGetErrorStringW ret)))))
 
-(define (play-sound path async?)
-  (let ([path (simplify-path path #f)]
-	[done (make-semaphore)])
-    (and (let ([p (path->string
-		   (cleanse-path (path->complete-path path)))])
-	   (atomically
-	    (when previous-done-sema (semaphore-post previous-done-sema))
-	    (set! previous-done-sema done)
-	    (PlaySoundW p #f SND_ASYNC)))
-	 (or async?
-	     ;; Implement synchronous playing by polling, where
-	     ;; PlaySound with no sound file and SND_NOSTOP polls.
-	     (let loop ()
-	       (sleep 0.1)
-	       (or (semaphore-try-wait? done)
-		   (PlaySoundW #f #f (bitwise-ior SND_ASYNC SND_NOSTOP))
-		   (loop)))))))
+(define (mci-send fmt . args)
+  (mciSendStringW (apply format fmt args)))
+
+(define-winmm mciSendStringW*
+  (_fun _string/utf-16
+	[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
+	[_int = BUFFER-SIZE]
+	[_pointer = #f]
+	-> [ret : _int]
+	-> (if (zero? ret)
+	       (cast buf _pointer _string/utf-16)
+	       (error 'mciSendStringW* "~a" (mciGetErrorStringW ret))))
+  #:c-id mciSendStringW)
+
+(define (mci-send* fmt . args)
+  (mciSendStringW* (apply format fmt args)))
+
+(define (play-sound file async?)
+  ;; Generated ID is unique enough, because we only
+  ;; instantiate this library in one place:
+  (define id (gensym 'play))
+  (define cust (make-custodian))
+  (call-as-atomic
+   (lambda ()
+     (mci-send "open \"~a\" alias ~a" (simplify-path file) id)
+     (register-custodian-shutdown
+      id
+      (lambda (id)
+        (mci-send "close ~a" id))
+      cust)))
+  (define (done msec)
+    (when msec (sleep (/ msec 1000)))
+    (custodian-shutdown-all cust))
+  (dynamic-wind
+   void
+   (lambda ()
+     (mci-send "set ~a time format milliseconds" id)
+     (define len (let ([s (mci-send* "status ~a length" id)])
+                   (string->number s)))
+     (unless len (error 'play "mci did not return a numeric length"))
+     (mci-send "play ~a" id)
+     (if async? (thread (lambda () (done len))) (done len)))
+   (lambda ()
+     (unless async?
+       (done #f))))
+  ;; Report success, since otherwise we throw an error:
+  #t)

gui-lib/mred/private/wxme/editor-canvas.rkt

@@ -170,6 +170,10 @@
            begin-refresh-sequence
            end-refresh-sequence)
 
+  (define scroll-via-copy? #f)
+  (define/public (set-scroll-via-copy v) (set! scroll-via-copy? (and v #t)))
+  (define/public (get-scroll-via-copy) scroll-via-copy?)
+
   (define blink-timer #f)
   (define noloop? #f)
 
@@ -306,14 +310,14 @@
            (maybe-reset-size))))))
 
   (define/private (maybe-reset-size)
-    (begin-refresh-sequence)
     (let-boxes ([w 0]
                 [h 0])
         (get-size w h)
       (unless (and (= w lastwidth)
                    (= h lastheight))
-        (reset-size)))
-    (end-refresh-sequence))
+        (begin-refresh-sequence)
+        (reset-size)
+        (end-refresh-sequence))))
 
   (define/private (reset-size)
     (reset-visual #f)
@@ -460,6 +464,7 @@
       (case (and (positive? wheel-amt)
                  code)
         [(wheel-up wheel-down)
+         (collect-garbage 'incremental)
          (when (and allow-y-scroll?
                     (not fake-y-scroll?))
            (let-boxes ([x 0]
@@ -474,6 +479,7 @@
                            0)])
                (do-scroll x y #t x old-y))))]
         [(wheel-left wheel-right)
+         (collect-garbage 'incremental)
          (when (and allow-x-scroll?
                     (not fake-x-scroll?))
            (let-boxes ([x 0]
@@ -628,12 +634,14 @@
         (when clear?
           (let ([bg (get-canvas-background)])
             (when bg
-              (let ([adc (get-dc)])
+              (let* ([dx (box 0)]
+                     [dy (box 0)]
+                     [adc (get-dc-and-offset dx dy)])
                 (let ([b (send adc get-brush)]
                       [p (send adc get-pen)])
                   (send adc set-brush bg 'solid)
                   (send adc set-pen bg 1 'transparent)
-                  (send adc draw-rectangle localx localy fw fh)
+                  (send adc draw-rectangle (- localx (unbox dx)) (- localy (unbox dy)) fw fh)
                   (send adc set-brush b)
                   (send adc set-pen p))))))
         (let ([x (box 0)]
@@ -940,11 +948,13 @@
                     retval)))))))
 
   (define/private (do-scroll x y refresh? old-x old-y)
+    (define ed (get-editor))
     (let ([savenoloop? noloop?])
       (set! noloop? #t)
       
       (maybe-reset-size)
-
+      (define on-scroll-to-called? #f)
+      
       (define change?
         (or
          ;; Set x
@@ -954,6 +964,14 @@
                 (and (not (= x old-x))
                      (begin
                        (when (not fake-x-scroll?)
+                         (when scroll-via-copy?
+                           (set! on-scroll-to-called? #t)
+                           (begin-refresh-sequence)
+                           (when scroll-via-copy?
+                             (when ed
+                               (call-as-primary-owner
+                                (λ ()
+                                  (send ed on-scroll-to))))))
                          (set-scroll-pos 'horizontal x))
                        #t))))
          ;; Set y
@@ -963,49 +981,77 @@
                 (and (not (= y old-y))
                      (begin
                        (when (not fake-y-scroll?)
+                         (unless on-scroll-to-called?
+                           (when scroll-via-copy?
+                             (set! on-scroll-to-called? #t)
+                             (begin-refresh-sequence)
+                             (when ed
+                               (call-as-primary-owner
+                                (λ ()
+                                  (send ed on-scroll-to))))))
                          (set-scroll-pos 'vertical y))
                        #t))))))
       
       (set! noloop? savenoloop?)
 
       (when (and change? refresh?)
-        (if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Windows
+        (if (and scroll-via-copy?
                  (not need-refresh?)
                  (not lazy-refresh?)
                  (get-canvas-background)
                  (= x old-x)) ; could handle horizontal scrolling in the future
             (let-boxes ([fx 0]
-                        [old-fy 0]
-                        [new-fy 0])
-                (begin
-                  (convert-scroll-to-location x y fx new-fy)
-                  (convert-scroll-to-location old-x old-y #f old-fy))
+                        [old-fy* 0]
+                        [new-fy* 0])
+                (let ([x (min x scroll-width)]
+                      [y (min y scroll-height)])
+                  (convert-scroll-to-location x y fx new-fy*)
+                  (convert-scroll-to-location old-x old-y #f old-fy*))
+              (define new-fy (floor new-fy*))
+              (define old-fy (floor old-fy*))
               (let-boxes ([vx 0][vy 0][vw 0][vh 0])
                   (get-view vx vy vw vh) ; editor coords
                 (cond
                  [(and (new-fy . < . old-fy)
-                       (old-fy . < . (+ new-fy vh)))
+                       (old-fy . < . (+ new-fy vh))
+                       (integer? (send (get-dc) get-backing-scale)))
                   (let ([dc (get-dc)])
+                    (unless on-scroll-to-called?
+                      (begin-refresh-sequence))
                     (send dc copy
                           xmargin ymargin
                           vw (- (+ new-fy vh) old-fy)
                           xmargin (+ ymargin (- old-fy new-fy)))
-                    (redraw xmargin ymargin 
+                    (redraw vx vy
                             vw (- old-fy new-fy)
-                            #t))]
+                            #t)
+                    (unless on-scroll-to-called?
+                      (end-refresh-sequence)))]
                  [(and (old-fy . < . new-fy)
-                       (new-fy . < . (+ old-fy vh)))
+                       (new-fy . < . (+ old-fy vh))
+                       (integer? (send (get-dc) get-backing-scale)))
                   (let ([dc (get-dc)])
+                    (unless on-scroll-to-called?
+                      (begin-refresh-sequence))
                     (send dc copy
                           xmargin (+ ymargin (- new-fy old-fy))
                           vw (- (+ old-fy vh) new-fy)
                           xmargin ymargin)
                     (let ([d (- (+ old-fy vh) new-fy)])
-                      (redraw xmargin (+ ymargin d)
+                      (redraw vx (+ vy d)
                               vw (- vh d)
-                              #t)))]
+                              #t))
+                    (unless on-scroll-to-called?
+                      (end-refresh-sequence)))]
                  [else (repaint)])))
-            (repaint)))))
+            (repaint)))
+
+      (when on-scroll-to-called?
+        (when ed
+          (call-as-primary-owner
+           (λ ()
+             (send ed after-scroll-to))))
+        (end-refresh-sequence))))
 
   (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void))
 

gui-lib/mred/private/wxme/editor.rkt

@@ -226,6 +226,11 @@
 
   ;; ----------------------------------------
 
+  (define/public (on-scroll-to) (void))
+  (define/public (after-scroll-to) (void))
+  
+  ;; ----------------------------------------
+
   (def/public (set-admin [(make-or-false editor-admin%) administrator])
     (setting-admin administrator)
 

gui-lib/mred/private/wxme/keymap.rkt

@@ -284,7 +284,7 @@
                       (if (caps . < . 0) "~l:" "")
                       (if (altgr . > . 0) "g:" "")
                       (if (altgr . < . 0) "~g:" "")
-                      (or (hash-ref rev-keylist code)
+                      (or (hash-ref rev-keylist code #f)
                           (format "~c" code)))])
                 (error (method-name 'keymap% 'map-function)
                        "~s is already mapped as a ~aprefix key"

gui-lib/mred/private/wxme/pasteboard.rkt

@@ -249,6 +249,11 @@
 
   (def/override (on-event [mouse-event% event])
     (when s-admin
+      (when (and (not (send event moving?))
+                 (not (send event entering?))
+                 (not (send event leaving?)))
+        ;; Request incremental mode to improve interactivity:
+        (collect-garbage 'incremental))
       (let-values ([(dc x y scrollx scrolly)
                     ;; first, find clicked-on snip:
                     (let ([x (send event get-x)]
@@ -404,6 +409,8 @@
 
   (def/override (on-char [key-event% event])
     (when s-admin
+      ;; Request incremental mode to improve interactivity:
+      (collect-garbage 'incremental)
       (let-boxes ([scrollx 0.0]
                   [scrolly 0.0]
                   [dc #f])
@@ -1860,7 +1867,7 @@
     (let ([snip (new string-snip%)])
       (set-snip-style! snip (or (get-default-style)
                                 (send s-style-list basic-style)))
-      (send snip insert str)
+      (send snip insert str (string-length str))
       (insert-paste-snip snip #f)))
   
   (def/override (kill [exact-integer? [time 0]])

gui-lib/mred/private/wxme/stream.rkt

@@ -381,6 +381,15 @@
                                 (unless recur? (inc-item-count))
                                 (let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)]) 
                                            (read si))])
+                                  (when (and recur? s)
+                                    ;; It's ok to have extra whitespace when reading a byte
+                                    ;; string in a sequence
+                                    (let loop ()
+                                      (define c (peek-byte si))
+                                      (unless (eof-object? c)
+                                        (when (char-whitespace? (integer->char c))
+                                          (read-byte si)
+                                          (loop)))))
                                   (if (or (not s)
                                           (not (eof-object? (read-byte si))))
                                       (fail)

gui-lib/mred/private/wxme/text.rkt

@@ -452,7 +452,9 @@
       (when (and (not (send event moving?))
                  (not (send event entering?))
                  (not (send event leaving?)))
-        (end-streaks '(except-key-sequence cursor delayed)))
+        (end-streaks '(except-key-sequence cursor delayed))
+        ;; Request incremental mode to improve interactivity:
+        (collect-garbage 'incremental))
       (let-values ([(dc x y scrollx scrolly)
                     ;; first, find clicked-on snip:
                     (let ([x (send event get-x)]
@@ -464,17 +466,16 @@
                         ;; FIXME: old code returned if !dc
                         (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
           (let ([snip
-                 (let-boxes ([onit? #f]
-                             [how-close 0.0]
+                 (let-boxes ([how-close 0.0]
                              [now 0])
-                     (set-box! now (find-position x y #f onit? how-close))
-                   ;; FIXME: the following refinement of `onit?' seems pointless
-                   (let ([onit? (and onit?
-                                     (not (zero? how-close))
-                                     ((abs how-close) . > . between-threshold))])
-                     (if onit?
-                         ;; we're in the snip's horizontal region...
-                         (let ([snip (do-find-snip now 'after)])
+                       (set-box! now (find-position x y #f #f how-close))
+                     (let* ([snip (do-find-snip now 'after)]
+                            [onit? (or (and (not (zero? how-close))
+                                            ((abs how-close) . > . between-threshold))
+                                       (has-flag? (snip->flags snip)
+                                                  HANDLES-BETWEEN-EVENTS))])
+                       (if onit?
+                           ;; we're in the snip's horizontal region...
                            ;; ... but maybe the mouse is above or below it.
                            (let-boxes ([top 0.0]
                                        [bottom 0.0]
@@ -484,8 +485,8 @@
                                  (get-snip-location snip dummy bottom #t))
                              (if (or (top . > . y) (y . > . bottom))
                                  #f
-                                 snip)))
-                         #f)))])
+                                 snip))
+                           #f)))])
             (when (send event button-down?)
               (set-caret-owner snip))
             (when (and prev-mouse-snip
@@ -601,7 +602,9 @@
                        (not (eq? 'control code))
                        (not (eq? 'menu code))
                        (not (equal? code #\nul)))
-              (hide-cursor))
+              (hide-cursor)
+              ;; Request incremental mode to improve interactivity:
+              (collect-garbage 'incremental))
             (on-local-char event)))))
 
   (def/override (on-default-char [key-event% event])

gui-lib/mred/private/wxpanel.rkt

@@ -97,13 +97,17 @@
 
       (define ignore-redraw-request? #f)
 
+      (define hide-scroll-x? (and (memq 'hide-hscroll style) #t))
+      (define hide-scroll-y? (and (memq 'hide-vscroll style) #t))
 
       (define auto-scroll-x? (and (memq 'auto-hscroll style) #t))
       (define auto-scroll-y? (and (memq 'auto-vscroll style) #t))
 
       (define can-scroll-x? (or auto-scroll-x?
+                                hide-scroll-x?
                                 (and (memq 'hscroll style) #t)))
       (define can-scroll-y? (or auto-scroll-y?
+                                hide-scroll-y?
                                 (and (memq 'vscroll style) #t)))
                 
       (define scroll-x? can-scroll-x?)
@@ -450,13 +454,15 @@
                                   ;; loop for fix-point on x and y scroll
                                   (let loop ([w w] [h h] [iters 0])
                                     (let ([want-scroll-x?
-                                           (if auto-scroll-x?
-                                               ((car ms) . > . w)
-                                               scroll-x?)]
+                                           (and (not hide-scroll-x?)
+                                                (if auto-scroll-x?
+                                                    ((car ms) . > . w)
+                                                    scroll-x?))]
                                           [want-scroll-y?
-                                           (if auto-scroll-y?
-                                               ((cadr ms) . > . h)
-                                               scroll-y?)])
+                                           (and (not hide-scroll-y?)
+                                                (if auto-scroll-y?
+                                                    ((cadr ms) . > . h)
+                                                    scroll-y?))])
                                       (if (and (eq? scroll-x? want-scroll-x?)
                                                (eq? scroll-y? want-scroll-y?))
                                           (values (if can-scroll-x?

gui-lib/mrlib/image-core.rkt

@@ -30,6 +30,7 @@ has been moved out).
          "private/image-core-snipclass.rkt"
          "private/regmk.rkt"
          racket/snip
+         (prefix-in : racket/base)
          (prefix-in cis: "cache-image-snip.rkt"))
 
 
@@ -454,9 +455,11 @@ has been moved out).
         (set-box/f! lspace 0)
         (set-box/f! rspace 0)))
 
-    (define/override (write f) 
-      (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))])
-        (send f put (bytes-length bytes) bytes)))
+    (define/override (write f)
+      (define bp (open-output-bytes))
+      (:write (list shape bb pinhole) bp)
+      (define bytes (get-output-bytes bp))
+      (send f put (bytes-length bytes) bytes))
     
     (super-new)
     

gui-lib/mrlib/interactive-value-port.rkt

@@ -1,7 +1,8 @@
-(module interactive-value-port mzscheme
-  (require mzlib/pretty
-           mred
-           mzlib/class
+#lang racket/base
+
+  (require racket/pretty
+           racket/gui/base
+           racket/class
            "syntax-browser.rkt")
   (provide set-interactive-display-handler
            set-interactive-write-handler
@@ -10,7 +11,7 @@
   (define op (current-output-port))
   (define (oprintf . x) (apply fprintf op x))
   
-  (define (set-interactive-display-handler port)
+  (define (set-interactive-display-handler port #:snip-handler [snip-handler #f])
     (let ([original-port-display-handler (port-display-handler port)])
       (port-display-handler
        port
@@ -18,19 +19,19 @@
          (cond
            [(string? val) (original-port-display-handler val port)]
            [else
-            (do-printing pretty-display val port)])))))
+            (do-printing pretty-display val port snip-handler)])))))
   
-  (define (set-interactive-write-handler port)
+  (define (set-interactive-write-handler port #:snip-handler [snip-handler #f])
     (port-write-handler
      port
      (λ (val port)
-       (do-printing pretty-print val port))))
+       (do-printing pretty-write val port snip-handler))))
   
-  (define (set-interactive-print-handler port)
+  (define (set-interactive-print-handler port #:snip-handler [snip-handler #f])
     (port-print-handler
       port
       (λ (val port)
-        (do-printing pretty-print val port))))
+        (do-printing pretty-print val port snip-handler))))
             
   (define (use-number-snip? x)
     (and #f
@@ -41,7 +42,7 @@
 
   (define default-pretty-print-current-style-table (pretty-print-current-style-table))
 
-  (define (do-printing pretty value port)
+  (define (do-printing pretty value port snip-handler)
     (parameterize (;; these handlers aren't used, but are set to override the user's settings
                    [pretty-print-print-line (λ (line-number op old-line dest-columns) 
                                                 (when (and (not (equal? line-number 0))
@@ -70,22 +71,19 @@
                       (cond
                         [(not (port-writes-special? port)) #f]
                         [(is-a? value snip%) 1]
-                        ;[(use-number-snip? value) 1]
                         [(syntax? value) 1]
                         [else #f]))]
                    [pretty-print-print-hook
                     (λ (value display? port)
                       (cond
                         [(is-a? value snip%)
-                         (write-special value port)
-                         1]
-                        #;
-                        [(use-number-snip? value)
-                         (write-special
-                          (number-snip:make-repeating-decimal-snip value #f)
-                          port)
+                         (cond
+                           [snip-handler
+                            (snip-handler value port)]
+                           [else
+                            (write-special value port)])
                          1]
                         [(syntax? value)
                          (write-special (render-syntax/snip value))]
                         [else (void)]))])
-      (pretty value port))))
+      (pretty value port)))