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

@@ -15,7 +15,8 @@
                      "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
+ Sets @racket[port]'s display handler (via
-@racket[port-display-handler]) so that when it encounters these
+ @racket[port-display-handler]) so that when it encounters
-values:
+ these values:
+ @itemize[@item{syntax objects}
+          @item{snips}]
 
-@itemize[
+ 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{exact, real, non-integral numbers}
+ 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].
 
- @item{syntax objects}
+ To show values embedded in lists and other compound object,
-
+ it uses @racket[pretty-display].
-]
+}
-
-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].}
 
 
-@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/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/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/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<%>

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

@@ -871,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).
 
@@ -2471,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.
@@ -2487,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/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/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
+ used to handle events which are not handled by @this-obj[].
- @racket[prefix?] is a true value, then @racket[next] will take
+
- precedence over other keymaps already chained to @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

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
+                                      'hscroll 'auto-hscroll 'hide-hscroll
-                                      'vscroll 'auto-vscroll)) null]
+                                      '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
+ and @racket['auto-vscroll] styles imply @racket['hscroll] and
- @racket['vscroll], but they cause the corresponding scrollbar to
+ @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/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-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/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/frame.rkt

@@ -1119,6 +1119,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)
       (unless (eq? (send macro-recording-message is-shown?)
@@ -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)])
+          (let ([searching-edit
-                                  (if (and focus-snip (is-a? focus-snip editor-snip%))
+                 (let loop ([txt top-searching-edit])
-                                      (send focus-snip get-editor)
+                   (define focus-snip (send txt get-focus-snip))
-                                      top-searching-edit))]
+                   (cond
+                     [(and focus-snip (is-a? focus-snip editor-snip%))
+                      (loop (send focus-snip get-editor))]
+                     [else txt]))]
                 
                 [not-found
                  (λ (found-edit skip-beep?)

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))]))
+         [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))
 
 (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)
@@ -709,6 +710,17 @@
             (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)
             (define start (send txt get-start-position))
@@ -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 
+  (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"))
-
   (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)])

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

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?
@@ -627,8 +625,7 @@
                 (let ([text (get-text contains id-end)])
                   (cond
                     [(member (classify-position contains) '(keyword symbol))
-                     (or (get-keyword-type text tabify-prefs)
+                     (get-head-sexp-type text)]
-                         'other)]
                     [else
                      'other]))))
          (define (procedure-indent)
@@ -694,18 +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.
+              ;;  unless
-              ;;  in that case, we just ignore the ellipsis
+              ;;    - 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
-                [(first-sexp-is-keyword? contains)
+                [(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
@@ -725,6 +728,21 @@
                       (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
     (define/private (second-sexp-is-ellipsis? contains)
@@ -753,6 +771,7 @@
       (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
@@ -763,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)
@@ -781,8 +807,8 @@
              (when (< first-para end-para)
                (end-busy-cursor)))))))
     
-    (define (tabify-all) (tabify-selection 0 (last-position)))
+    (define/public (tabify-all) (tabify-selection 0 (last-position)))
-    (define (insert-return)
+    (define/public (insert-return)
       (begin-edit-sequence #t #f)
       (define end-of-whitespace (get-start-position))
       (define start-cutoff
@@ -806,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))
@@ -817,56 +843,54 @@
                          last-para)))
             last-para)))
     
-    (define comment-out-selection 
+    (define/public (comment-out-selection [start-pos (get-start-position)] 
-      (lambda ([start-pos (get-start-position)] 
+                                          [end-pos (get-end-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 (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)
-        (let ([first-pos-is-first-para-pos? 
+        (split-snip start-pos)
-               (= (paragraph-start-position (position-paragraph start-pos)) 
+        (split-snip end-pos)
-                  start-pos)]) 
+        (let* ([cb (instantiate comment-box:snip% ())]
-          (let* ([first-para (position-paragraph start-pos)] 
+               [text (send cb get-editor)])
-                 [last-para (calc-last-para end-pos)]) 
+          (let loop ([snip (find-snip start-pos 'after-or-none)])
-            (let para-loop ([curr-para first-para]) 
+            (cond
-              (when (<= curr-para last-para) 
+              [(not snip) (void)]
-                (let ([first-on-para (paragraph-start-position curr-para)]) 
+              [((get-snip-position snip) . >= . end-pos) (void)]
-                  (insert #\; first-on-para) 
+              [else
-                  (para-loop (add1 curr-para)))))) 
+               (send text insert (send snip copy)
-          (when first-pos-is-first-para-pos? 
+                     (send text last-position)
-            (set-position 
+                     (send text last-position))
-             (paragraph-start-position (position-paragraph (get-start-position))) 
+               (loop (send snip next))]))
-             (get-end-position)))) 
+          (delete start-pos end-pos)
+          (insert cb start-pos)
+          (set-position start-pos start-pos))
         (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)))
-    
     ;; uncomment-box/selection : -> void
     ;; uncomments a comment box, if the focus is inside one.
     ;; otherwise, calls uncomment selection to uncomment
@@ -885,44 +909,43 @@
       (end-edit-sequence)
       #t)
     
-    (define uncomment-selection
+    (define/public (uncomment-selection [start-pos (get-start-position)]
-      (lambda ([start-pos (get-start-position)]
+                                        [end-pos (get-end-position)])
-               [end-pos (get-end-position)])
+      (let ([snip-before (find-snip start-pos 'before-or-none)]
-        (let ([snip-before (find-snip start-pos 'before-or-none)]
+            [snip-after (find-snip start-pos 'after-or-none)])
-              [snip-after (find-snip start-pos 'after-or-none)])
           
-          (begin-edit-sequence)
+        (begin-edit-sequence)
-          (cond
+        (cond
-            [(and (= start-pos end-pos)
+          [(and (= start-pos end-pos)
-                  snip-before
+                snip-before
-                  (is-a? snip-before comment-box:snip%))
+                (is-a? snip-before comment-box:snip%))
-             (extract-contents start-pos snip-before)]
+           (extract-contents start-pos snip-before)]
-            [(and (= start-pos end-pos)
+          [(and (= start-pos end-pos)
-                  snip-after
+                snip-after
-                  (is-a? snip-after comment-box:snip%))
+                (is-a? snip-after comment-box:snip%))
-             (extract-contents start-pos snip-after)]
+           (extract-contents start-pos snip-after)]
-            [(and (= (+ start-pos 1) end-pos)
+          [(and (= (+ start-pos 1) end-pos)
-                  snip-after
+                snip-after
-                  (is-a? snip-after comment-box:snip%))
+                (is-a? snip-after comment-box:snip%))
-             (extract-contents start-pos snip-after)]
+           (extract-contents start-pos snip-after)]
-            [else
+          [else
-             (let* ([last-pos (last-position)]
+           (let* ([last-pos (last-position)]
-                    [first-para (position-paragraph start-pos)]
+                  [first-para (position-paragraph start-pos)]
-                    [last-para (calc-last-para end-pos)])
+                  [last-para (calc-last-para end-pos)])
-               (let para-loop ([curr-para first-para])
+             (let para-loop ([curr-para first-para])
-                 (when (<= curr-para last-para)
+               (when (<= curr-para last-para)
-                   (let ([first-on-para
+                 (let ([first-on-para
-                          (skip-whitespace  (paragraph-start-position curr-para)
+                        (skip-whitespace  (paragraph-start-position curr-para)
-                                            'forward
+                                          'forward
-                                            #f)])
+                                          #f)])
-                     (split-snip first-on-para)
+                   (split-snip first-on-para)
-                     (when (and (< first-on-para last-pos)
+                   (when (and (< first-on-para last-pos)
-                                (char=? #\; (get-character first-on-para))
+                              (char=? #\; (get-character first-on-para))
-                                (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
+                              (is-a? (find-snip first-on-para 'after-or-none) string-snip%))
-                       (delete first-on-para (+ first-on-para 1)))
+                     (delete first-on-para (+ first-on-para 1)))
-                     (para-loop (add1 curr-para))))))])
+                   (para-loop (add1 curr-para))))))])
-          (end-edit-sequence))
+        (end-edit-sequence))
-        #t))
+      #t)
     
     ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
     ;; copies the contents of the comment-box-snip out of the snip
@@ -1000,13 +1023,12 @@
             (set-position end-pos)
             (bell))
         #t))
-    [define flash-forward-sexp
+    (define/public (flash-forward-sexp start-pos)
-      (λ (start-pos)
+      (let ([end-pos (get-forward-sexp start-pos)])
-        (let ([end-pos (get-forward-sexp start-pos)])
+        (if end-pos 
-          (if end-pos 
+            (flash-on end-pos (add1 end-pos))
-              (flash-on end-pos (add1 end-pos))
+            (bell)) 
-              (bell)) 
+        #t))
-          #t))]
     (define/public (get-backward-sexp start-pos)
       (let* ([limit (get-limit start-pos)]
              [end-pos (backward-match start-pos limit)]
@@ -1025,89 +1047,82 @@
                     end-pos)))
             ;; can't go backward at all:
             #f)))
-    [define flash-backward-sexp
+    (define/public (flash-backward-sexp start-pos)
-      (λ (start-pos)
+      (let ([end-pos (get-backward-sexp start-pos)])
-        (let ([end-pos (get-backward-sexp start-pos)])
+        (if end-pos
-          (if end-pos
+            (flash-on end-pos (add1 end-pos))
-              (flash-on end-pos (add1 end-pos))
+            (bell))
-              (bell))
+        #t))
-          #t))]
+    (define/public (backward-sexp start-pos)
-    [define backward-sexp
+      (let ([end-pos (get-backward-sexp start-pos)])
-      (λ (start-pos)
+        (if end-pos
-        (let ([end-pos (get-backward-sexp start-pos)])
+            (set-position end-pos)
-          (if end-pos
+            (bell))
-              (set-position end-pos)
+        #t))
-              (bell))
+    (define/public (find-up-sexp start-pos)
-          #t))]
+      (let* ([limit-pos (get-limit start-pos)]
-    [define find-up-sexp
+             [exp-pos
-      (λ (start-pos)
+              (backward-containing-sexp start-pos limit-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))
+        (if (and exp-pos (> exp-pos limit-pos))
-              (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
+            (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
-                     [paren-pos
+                   [paren-pos
-                      (λ (paren-pair)
+                    (λ (paren-pair)
-                        (find-string
+                      (find-string
-                         (car paren-pair)
+                       (car paren-pair)
-                         'backward
+                       'backward
-                         in-start-pos
+                       in-start-pos
-                         limit-pos))])
+                       limit-pos))])
-                (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
+              (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
-                              (cond
+                            (cond
-                                [(null? parens) null]
+                              [(null? parens) null]
-                                [else 
+                              [else 
-                                 (let ([pos (paren-pos (car parens))])
+                               (let ([pos (paren-pos (car parens))])
-                                   (if pos
+                                 (if pos
-                                       (cons pos (loop (cdr parens)))
+                                     (cons pos (loop (cdr parens)))
-                                       (loop (cdr parens))))]))])
+                                     (loop (cdr parens))))]))])
-                  (if (null? poss) ;; all finds failed
+                (if (null? poss) ;; all finds failed
-                      #f
+                    #f
-                      (- (apply max poss) 1)))) ;; subtract one to move outside the paren
+                    (- (apply max poss) 1)))) ;; subtract one to move outside the paren
-              #f)))]
+            #f)))
-    [define up-sexp
+    (define/public (up-sexp start-pos)
-      (λ (start-pos)
+      (let ([exp-pos (find-up-sexp start-pos)])
-        (let ([exp-pos (find-up-sexp start-pos)])
+        (if exp-pos
-          (if exp-pos
+            (set-position exp-pos)
-              (set-position exp-pos)
+            (bell))
-              (bell))
+        #t))
-          #t))]
+    (define/public (find-down-sexp start-pos)
-    [define find-down-sexp
+      (let loop ([pos start-pos])
-      (λ (start-pos)
+        (let ([next-pos (get-forward-sexp pos)])
-        (let loop ([pos start-pos])
+          (if (and next-pos (> next-pos pos))
-          (let ([next-pos (get-forward-sexp pos)])
+              (let ([back-pos
-            (if (and next-pos (> next-pos pos))
+                     (backward-containing-sexp (sub1 next-pos) pos)])
-                (let ([back-pos
+                (if (and back-pos
-                       (backward-containing-sexp (sub1 next-pos) pos)])
+                         (> back-pos pos))
-                  (if (and back-pos
+                    back-pos
-                           (> back-pos pos))
+                    (loop next-pos)))
-                      back-pos
+              #f))))
-                      (loop next-pos)))
+    (define/public (down-sexp start-pos)
-                #f))))]
+      (let ([pos (find-down-sexp start-pos)])
-    [define down-sexp
+        (if pos
-      (λ (start-pos)
+            (set-position pos)
-        (let ([pos (find-down-sexp start-pos)])
+            (bell))
-          (if pos
+        #t))
-              (set-position pos)
+    (define/public (remove-parens-forward start-pos)
-              (bell))
+      (let* ([pos (skip-whitespace start-pos 'forward #f)]
-          #t))]
+             [first-char (get-character pos)]
-    [define remove-parens-forward
+             [paren? (or (char=? first-char #\()
-      (λ (start-pos)
+                         (char=? first-char #\[)
-        (let* ([pos (skip-whitespace start-pos 'forward #f)]
+                         (char=? first-char #\{))]
-               [first-char (get-character pos)]
+             [closer (and paren? 
-               [paren? (or (char=? first-char #\()
+                          (get-forward-sexp pos))])
-                           (char=? first-char #\[)
+        (if (and paren? closer)
-                           (char=? first-char #\{))]
+            (begin (begin-edit-sequence #t #f)
-               [closer (and paren? 
+                   (delete pos (add1 pos))
-                            (get-forward-sexp pos))])
+                   (delete (-  closer 2) (- closer 1))
-          (if (and paren? closer)
+                   (end-edit-sequence))
-              (begin (begin-edit-sequence #t #f)
+            (bell))
-                     (delete pos (add1 pos))
+        #t))
-                     (delete (-  closer 2) (- closer 1))
-                     (end-edit-sequence))
-              (bell))
-          #t))]
     
     (define/private (select-text f forward?)
       (define start-pos (get-start-position))
@@ -1124,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/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t))
-    [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
+    (define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f))
-    [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
+    (define/public (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-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t))
     
     (define/public (introduce-let-ans pos)
       (dynamic-wind
@@ -1274,10 +1289,9 @@
                                 (for-each (λ (s) (insert s start-1)) snips-2/rev)
                                 (set-position end-2)
                                 (end-edit-sequence)))))))))))
-    [define tab-size 8]
+    (define tab-size 8)
-    (public get-tab-size set-tab-size)
+    (define/public (get-tab-size) tab-size)
-    [define get-tab-size (λ () tab-size)]
+    (define/public (set-tab-size s) (set! tab-size s))
-    [define set-tab-size (λ (s) (set! tab-size s))]
     
     (define/override (get-start-of-line pos)
       (define para (position-paragraph pos))
@@ -1345,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)]))
@@ -1364,9 +1378,9 @@
                           (|[| |]|)
                           (|{| |}|))))))
 
-;; get-keyword-type : string (list ht regexp regexp regexp)
+;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp)
-;;                 -> (or/c #f 'lambda 'define 'begin 'for/fold)
+;;                              -> (or/c #f 'lambda 'define 'begin 'for/fold)
-(define (get-keyword-type text pref)
+(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
+(provide
- [find-string-embedded
+ (contract-out
-  (->* ((is-a?/c text%)
+  [find-string-embedded
-        string?)
+   (->* ((is-a?/c text%)
-       ((symbols 'forward 'backward)
+         string?)
-        (or/c (symbols 'start) number?)
+        ((or/c 'forward 'backward)
-        (or/c (symbols 'eof) number?)
+         (or/c 'start number?)
-        boolean?
+         (or/c 'eof number?)
-        boolean?
+         boolean?
-        boolean?)
+         boolean?
-      (values (is-a?/c editor<%>)
+         boolean?)
-              (or/c false/c number?)))])
+        (values (is-a?/c editor<%>)
+                (or/c #f number?)))]))
 
-(define find-string-embedded
+(define (find-string-embedded a-text
-  (lambda (edit
+                              str
-           str
+                              [direction 'forward]
-           [direction 'forward]
+                              [start 'start]
-           [start 'start]
+                              [end 'eof]
-           [end 'eof]
+                              [get-start #t]
-           [get-start #t]
+                              [case-sensitive? #t]
-           [case-sensitive? #t]
+                              [pop-out? #f])
-           [pop-out? #f])
+  (let/ec k
-    (let/ec k
+    (let loop ([a-text a-text]
-      (let* ([start (if (eq? start 'start) 
+               [start start]
-                        (send edit get-start-position)
+               [end end])
-                        start)]
+      (define found (send a-text find-string-embedded str direction start end get-start case-sensitive?))
-             [end (if (eq? 'eof end)
+      (define (done)
-                      (if (eq? direction 'forward)
+        (cond
-                          (send edit last-position)
+          [(not found)
-                          0)
+           (k a-text found)]
-                      end)]
+          [else
-             [flat (send edit find-string str direction
+           (let loop ([a-text a-text]
-                         start end get-start
+                      [found found])
-                         case-sensitive?)]
+             (cond
-             [pop-out
+               [(number? found)
-              (λ ()
+                (k a-text found)]
-                (let ([admin (send edit get-admin)])
+               [else (loop (car found) (cdr found))]))]))
-                  (if (is-a? admin editor-snip-editor-admin<%>)
+      (when found (done))
-                      (let* ([snip (send admin get-snip)]
+      (unless pop-out? (done))
-                             [edit-above (send (send snip get-admin) get-editor)]
+      (define a-text-admin (send a-text get-admin))
-                             [pos (send edit-above get-snip-position snip)]
+      (unless (is-a? a-text-admin editor-snip-editor-admin<%>) (done))
-                             [pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
+      (define editor-snip (send a-text-admin get-snip))
-                        (find-string-embedded
+      (define editor-snip-admin (send editor-snip get-admin))
-                         edit-above
+      (unless editor-snip-admin (done))
-                         str
+      (define enclosing-text (send editor-snip-admin get-editor))
-                         direction 
+      (unless (is-a? enclosing-text text%) (done))
-                         pop-out-pos
+      (loop enclosing-text
-                         (if (eq? direction 'forward) 'eof 0)
+            (+ (send enclosing-text get-snip-position editor-snip)
-                         get-start
+               (send editor-snip get-count))
-                         case-sensitive?
+            'eof))))
-                         pop-out?))
+
-                      (values edit #f))))])
+(module+ test
-        (let loop ([current-snip (send edit find-snip start
+  (require rackunit)
-                                       (if (eq? direction 'forward)
+
-                                           'after-or-none
+  (define abcX (new text%))
-                                           'before-or-none))])
+  (send abcX insert "abcX")
-          (let ([next-loop
+
-                 (λ ()
+  (define abc/abcX/abcQ (new text%))
-                   (if (eq? direction 'forward)
+  (send abc/abcX/abcQ insert "abc")
-                       (loop (send current-snip next))
+  (send abc/abcX/abcQ insert (new editor-snip% [editor abcX]))
-                       (loop (send current-snip previous))))])
+  (send abc/abcX/abcQ insert "abcQ")
-            (cond
+
-              [(or (not current-snip)
+  (define abc//abc/abcX/abcQ//abcZ (new text%))
-                   (and flat
+  (send abc//abc/abcX/abcQ//abcZ insert "abc")
-                        (let* ([start (send edit get-snip-position current-snip)]
+  (send abc//abc/abcX/abcQ//abcZ insert (new editor-snip% [editor abc/abcX/abcQ]))
-                               [end (+ start (send current-snip get-count))])
+  (send abc//abc/abcX/abcQ//abcZ insert "abcZ")
-                          (if (eq? direction 'forward)
+  
-                              (and (<= start flat)
+  (let ()
-                                   (< flat end))
+    (define-values (ta pos) (find-string-embedded abcX "b" 'forward 0))
-                              (and (< start flat)
+    (check-equal? ta abcX)
-                                   (<= flat end))))))
+    (check-equal? pos 1))
-               (if (and (not flat) pop-out?)
+
-                   (pop-out)
+  (let ()
-                   (values edit flat))]
+    (define-values (ta pos) (find-string-embedded abcX "c" 'forward 0))
-              [(is-a? current-snip editor-snip%)
+    (check-equal? ta abcX)
-               (let-values ([(embedded embedded-pos)
+    (check-equal? pos 2))
-                             (let ([media (send current-snip get-editor)])
+
-                               (if (and media
+  (let ()
-                                        (is-a? media text%))
+    (define-values (ta pos) (find-string-embedded abcX "d" 'forward 2))
-                                   (begin
+    (check-equal? pos #f))
-                                     (find-string-embedded 
+
-                                      media 
+  (let ()
-                                      str
+    (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0))
-                                      direction
+    (check-equal? ta ta)
-                                      (if (eq? 'forward direction)
+    (check-equal? pos 1))
-                                          0
+
-                                          (send media last-position))
+  (let ()
-                                      'eof
+    (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2))
-                                      get-start case-sensitive?))
+    (check-equal? ta abcX)
-                                   (values #f #f)))])
+    (check-equal? pos 1))
-                 (if (not embedded-pos)
+
-                     (next-loop)
+  (let ()
-                     (values embedded embedded-pos)))]
+    (define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0))
-              [else (next-loop)])))))))
+    (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

@@ -182,6 +182,7 @@
   (define-signature text-class^
     (basic<%>
      line-spacing<%>
+     ascii-art-enlarge-boxes<%>
      first-line<%>
      line-numbers<%>
      foreground-color<%>
@@ -225,6 +226,7 @@
      
      basic-mixin
      line-spacing-mixin
+     ascii-art-enlarge-boxes-mixin
      first-line-mixin
      line-numbers-mixin
      foreground-color-mixin
@@ -259,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)
 
@@ -869,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<%>)
@@ -1137,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)
     
@@ -1267,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
@@ -1293,17 +1378,28 @@
         (queue-callback
          (λ ()
            (when searching-str
-             (define count 0)
+             (define start-pos (get-focus-editor-start-position))
-             (define start-pos (get-start-position))
+             (define count
-             (hash-for-each
+               (for/sum ([(k v) (in-hash search-bubble-table)])
-              search-bubble-table
+                 (define n (if (search-result-compare <= (car k) start-pos) 1 0))
-              (λ (k v)
+                 n))
-                (when (<= (car k) start-pos)
-                  (set! count (+ count 1)))))
              (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)
         (set! before-caret-search-hit-count c)
@@ -1329,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?)
@@ -1348,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)))))
@@ -1413,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-end (search-result+ bubble-start (string-length searching-str)))
-                (define bubble (cons bubble-start bubble-end))
+                (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
@@ -1488,14 +1593,81 @@
                [(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)
+    (define/private (do-search start)
-      (find-string searching-str 'forward start end #t case-sensitive?))
+      (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
@@ -1505,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)
+    (define/private (unhighlight-hit bubble)
-      (hash-remove! search-bubble-table pair)
+      (hash-remove! search-bubble-table bubble)
-      (unhighlight-range (car pair) (cdr pair) 
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
-                         (if replace-mode? light-search-color normal-search-color)
+      (when txt
-                         #f
+        (send txt unhighlight-range
-                         'hollow-ellipse))
+              start end
-    (define/private (highlight-hit pair)
+              (if replace-mode? light-search-color normal-search-color)
-      (hash-set! search-bubble-table pair #t)
+              #f
-      (highlight-range (car pair) (cdr pair) 
+              'hollow-ellipse)))
-                       (if replace-mode? light-search-color normal-search-color)
+    (define/private (highlight-hit bubble)
-                       #f
+      (hash-set! search-bubble-table bubble #t)
-                       'low
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
-                       'hollow-ellipse
+      (when txt
-                       #:key 'plt:framework:search-bubbles
+        (hash-set! all-txt-with-regions-to-clear txt #t)
-                       #:adjust-on-insert/delete? #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)
+      (define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight))
-                         (cdr to-replace-highlight)
+      (when txt
-                         dark-search-color
+        (send txt unhighlight-range
-                         #f
+              start end
-                         'hollow-ellipse)
+              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)
+      (define-values (txt start end) (get-highlighting-text-and-range new-to-replace))
-                       (cdr to-replace-highlight)
+      (when txt
-                       dark-search-color
+        (send txt highlight-range
-                       #f
+              start end
-                       'high
+              dark-search-color
-                       'hollow-ellipse))
+              #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)
@@ -2270,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%
+       (with-handlers ([exn:fail? values])
-                      (snip-special-bytes snip-special)))
+         (define base (make-object editor-stream-in-bytes-base%
-       (define es (make-object editor-stream-in% base))
+                        (snip-special-bytes snip-special)))
-       (or (send snipclass read es)
+         (define es (make-object editor-stream-in% base))
-           (snip-special-snip snip-special))]
+         (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)]))
   
@@ -2639,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)
@@ -2648,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))]
+                (define the-snip
-               [else (car fst)]))
+                  (snip-special->snip (car fst)))
-           (define style (cdr 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%)
@@ -2861,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-write-handler port #:snip-handler send-snip-to-port)
-                 (set-interactive-display-handler port))])
+                 (set-interactive-display-handler port #:snip-handler send-snip-to-port))])
           (install-handlers out-port)
           (install-handlers err-port)
           (install-handlers value-port))))
@@ -3001,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%))
     ))

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/info.rkt

@@ -4,7 +4,7 @@
 
 (define deps '("srfi-lite-lib"
                "data-lib"
-               ["base" #:version "6.4"]
+               ["base" #:version "6.5.0.2"]
                "syntax-color-lib"
                ["draw-lib" #:version "1.13"]
                ["snip-lib" #:version "1.2"]
@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.24")
+(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?))
+         (prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
-         #:cmdline '("-I" "scheme/gui/init")
+         #: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?))
+           (prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
-           `([relative? . ,(not user?)] [subsystem . console] [single-instance? . #f]))))))
+           `([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
-         '()
+         #:tether-mode tether-mode
-         (prep-dir (mred-program-launcher-path "MrEd" #:user? user?))
+         null
-         '([exe-name . "GRacket"] [relative? . ,(not user?)] [exe-is-gracket . #t]))))))
+         (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/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/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?)

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/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/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?
+                                           (and (not hide-scroll-x?)
-                                               ((car ms) . > . w)
+                                                (if auto-scroll-x?
-                                               scroll-x?)]
+                                                    ((car ms) . > . w)
+                                                    scroll-x?))]
                                           [want-scroll-y?
-                                           (if auto-scroll-y?
+                                           (and (not hide-scroll-y?)
-                                               ((cadr ms) . > . h)
+                                                (if auto-scroll-y?
-                                               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"))
 
 
@@ -455,8 +456,10 @@ has been moved out).
         (set-box/f! rspace 0)))
 
     (define/override (write f)
-      (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))])
+      (define bp (open-output-bytes))
-        (send f put (bytes-length bytes) 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
+#lang racket/base
-  (require mzlib/pretty
+
-           mred
+  (require racket/pretty
-           mzlib/class
+           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)
+                         (cond
-                         1]
+                           [snip-handler
-                        #;
+                            (snip-handler value port)]
-                        [(use-number-snip? value)
+                           [else
-                         (write-special
+                            (write-special value port)])
-                          (number-snip:make-repeating-decimal-snip value #f)
-                          port)
                          1]
                         [(syntax? value)
                          (write-special (render-syntax/snip value))]
                         [else (void)]))])
-      (pretty value port))))
+      (pretty value port)))

gui-lib/mrlib/syntax-browser.rkt

@@ -11,6 +11,7 @@ needed to really make this work:
            racket/class
            racket/gui/base
            racket/match
+           (prefix-in - racket/base)
            "include-bitmap.rkt")
 
   (define orig-output-port (current-output-port))
@@ -46,7 +47,7 @@ needed to really make this work:
     (class snip-class%
       (define/override (read stream)
         (make-object syntax-snip%
-          (unmarshall-syntax (read (open-input-string (send stream get-bytes))))))
+          (unmarshall-syntax (-read (open-input-bytes (send stream get-bytes))))))
       (super-new)))
   
   (define snip-class (new syntax-snipclass%))

gui-lib/racket/gui/info.rkt

@@ -1,4 +1,4 @@
 #lang info
 
-(define post-install-collection "installer.rkt")
+(define install-collection "installer.rkt")
 (define copy-man-pages '("gracket.1"))

gui-lib/racket/gui/installer.rkt

@@ -1,32 +1,47 @@
 #lang racket/base
 (require launcher
          racket/path
-         racket/file)
+         racket/file
+         setup/dirs)
 
-(provide post-installer)
+(provide installer)
 
-(define (post-installer path collection 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 collection user? tethered?)
   (define variants (available-mred-variants))
+  (define tether-mode (and tethered? (if user? 'addon 'config)))
   ;; add a gracket-text executable that uses the -z flag (preferring a script)
   (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-mred-launcher
+           #:tether-mode tether-mode
            '("-z")
            (prep-dir
-            (mred-program-launcher-path "gracket-text" #:user? user?))
+            (mred-program-launcher-path "gracket-text" #:user? user? #:tethered? tethered?))
-           `([subsystem . console] [single-instance? . #f]
+           `([subsystem . console]
-             [relative? . ,(not user?)]))))))
+             [single-instance? . #f]
+             [relative? . ,(not (or user? tethered?))]))))))
   ;; add a bin/gracket (in addition to lib/gracket)
   (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-mred-launcher null
+          (make-mred-launcher #:tether-mode tether-mode
+                              null
                               (prep-dir
-                               (mred-program-launcher-path "GRacket" #:user? user?))
+                               (mred-program-launcher-path "GRacket" #:user? user? #:tethered? tethered?))
-                              '([exe-name . "GRacket"] [relative? . ,(not user?)]
+                              `([exe-name . "GRacket"]
+                                [relative? . ,(not (or user? tethered?))]
                                 [exe-is-gracket . #t])))))))
 
 (define (prep-dir p)

gui-lib/racket/gui/interactive.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(require racket/gui/base)
+
+(let ([init-file (cleanse-path (find-graphical-system-path 'init-file))])
+  (when (file-exists? init-file)
+    (load init-file)))

gui-test/framework/tests/frame.rkt

@@ -128,8 +128,6 @@
        (queue-callback
         (λ ()
           (send (test:get-active-top-level-window) close)))
-       (preferences:set 'framework:file-dialogs 'std) ;; this is not gooD!!!!
-       (error 'ack "need to figure out how to use the hash-based prefs...?")
        editor-contents))
    test-file-contents
    name))
@@ -138,9 +136,19 @@
   (test-open "frame:searchable open" frame:searchable%)
   (test-open "frame:text open" frame:text%))
 
-(parameterize ([test:use-focus-table #t])
+(let ([pref-ht (make-hash)])
-  (define dummy (make-object frame:basic% "dummy to keep from quitting"))
+  (parameterize ([test:use-focus-table #t]
-  (send dummy show #t)
+                 [preferences:low-level-get-preference
-  (creation-tests)
+                  (λ (sym [fail (λ () #f)])
-  (open-tests)
+                    (hash-ref pref-ht sym fail))]
-  (send dummy show #f))
+                 [preferences:low-level-put-preferences
+                  (λ (syms vals)
+                    (for ([sym (in-list syms)]
+                          [val (in-list vals)])
+                      (hash-set! pref-ht sym val)))])
+    (define dummy (make-object frame:basic% "dummy to keep from quitting"))
+    (send dummy show #t)
+    (creation-tests)
+    (open-tests)
+    (send dummy show #f)))
+

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

@@ -4,7 +4,7 @@
 (module test racket/base)
 
 (define windows-menu-prefix 
-  (let ([basics (list "Bring Frame to Front..." "Most Recent Window" 
+  (let ([basics (list "Bring Frame to Front…" "Most Recent Window"
                       #f)])
     (if (eq? (system-type) 'macosx)
         (list* "Minimize" "Zoom" basics)

gui-test/framework/tests/keys.rkt

@@ -90,6 +90,26 @@
              string<?
              #:key (lambda (x) (format "~s" x)))))))
 
+(test
+ 'keymap:aug-keymap%/longer-name
+ (lambda (x)
+   (equal? x '((|c:x;r| "swap if branches"))))
+ (lambda ()
+   (queue-sexp-to-mred
+    '(let ()
+       (define k0 (new keymap:aug-keymap%))
+       (define k1 (new keymap:aug-keymap%))
+       (define k2 (new keymap:aug-keymap%))
+       (send k1 add-function "rectangle" void)
+       (send k1 map-function "c:x;r;a" "rectangle")
+       (send k2 add-function "swap if branches" void)
+       (send k2 map-function "c:x;r" "swap if branches")
+       (send k0 chain-to-keymap k1 #t)
+       (send k0 chain-to-keymap k2 #t)
+       (sort (hash-map (send k0 get-map-function-table) list)
+             string<?
+             #:key (lambda (x) (format "~s" x)))))))
+  
   (define (test-canonicalize name str1 str2)
     (test
      (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))

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

@@ -3,7 +3,7 @@
 
 (test
  'number-snip-convert-text
- (λ (x) (equal? "1/2" x))
+ (λ (x) (or (equal? "1/2" x) (equal? "0.5" x)))
  (lambda ()
    (queue-sexp-to-mred
     `((dynamic-require 'file/convertible 'convert)

gui-test/framework/tests/racket.rkt

@@ -175,6 +175,10 @@
                   "(#:x\n 1)")
 (test-indentation "(#:x 0\n1)"
                   "(#:x 0\n 1)")
+(test-indentation "(a b c d\n---)"
+                  "(a b c d\n ---)")
+(test-indentation "[---- \"β\"\na"
+                  "[---- \"β\"\n a")
 
 
 (define (test-magic-square-bracket which before after)

gui-test/framework/tests/search.rkt

@@ -67,35 +67,35 @@
                            (send t set-searching-state "aba" #t #f)
                            (send t set-position 0 0)))
              `(((0 . 3) normal-search-color)
-               ((4 . 7) normal-search-color)))
+               ((4 . 3) normal-search-color)))
 (test-search (list '(begin (send t insert "aba aba")
                            (send t set-searching-state "aba" #t #f))
                    '(send t set-position 0 0))
              `(((0 . 3) normal-search-color)
-               ((4 . 7) normal-search-color)))
+               ((4 . 3) normal-search-color)))
 
 
 (test-search (list '(begin (send t insert "abaaba")
                            (send t set-searching-state "aba" #t #f)
                            (send t set-position 0 0)))
              `(((0 . 3) normal-search-color)
-               ((3 . 6) normal-search-color)))
+               ((3 . 3) normal-search-color)))
 (test-search (list '(begin (send t insert "abaaba")
                            (send t set-searching-state "aba" #t #f))
                    '(send t set-position 0 0))
              `(((0 . 3) normal-search-color)
-               ((3 . 6) normal-search-color)))
+               ((3 . 3) normal-search-color)))
 
 (test-search (list '(begin (send t insert "abababa")
                            (send t set-searching-state "aba" #t #f)
                            (send t set-position 0 0)))
              `(((0 . 3) normal-search-color)
-               ((4 . 7) normal-search-color)))
+               ((4 . 3) normal-search-color)))
 (test-search (list '(begin (send t insert "abababa")
                            (send t set-searching-state "aba" #t #f))
                    '(send t set-position 0 0))
              `(((0 . 3) normal-search-color)
-               ((4 . 7) normal-search-color)))
+               ((4 . 3) normal-search-color)))
 
 (test-search (list '(begin (send t insert "Aba")
                            (send t set-searching-state "aba" #t #f)
@@ -131,25 +131,25 @@
                            (send t set-searching-state "aba" #f #t)
                            (send t set-position 0 0)))
              `(((0 . 3) dark-search-color) 
-               ((4 . 7) light-search-color)))
+               ((4 . 3) light-search-color)))
 (test-search (list '(begin (send t insert "abababa")
                            (send t set-searching-state "aba" #f #t))
                    '(send t set-position 0 0))
              `(((0 . 3) dark-search-color) 
-               ((4 . 7) light-search-color)))
+               ((4 . 3) light-search-color)))
 
 (test-search (list '(begin (send t insert "aba aba aba")
                            (send t set-searching-state "aba" #f #t)
                            (send t set-position 1 1)))
              `(((0 . 3) light-search-color)
-               ((4 . 7) dark-search-color)
+               ((4 . 3) dark-search-color)
-               ((8 . 11) light-search-color)))
+               ((8 . 3) light-search-color)))
 (test-search (list '(begin (send t insert "aba aba aba")
                            (send t set-searching-state "aba" #f #t))
                    '(send t set-position 1 1))
              `(((0 . 3) light-search-color)
-               ((4 . 7) dark-search-color)
+               ((4 . 3) dark-search-color)
-               ((8 . 11) light-search-color)))
+               ((8 . 3) light-search-color)))
 
 (test-search (list '(begin (send t insert "aba")
                            (send t set-searching-state "aba" #f #t))

gui-test/framework/tests/test-suite-utils.rkt

@@ -14,7 +14,7 @@
  
  load-framework-automatically
  shutdown-listener shutdown-mred mred-running?
- send-sexp-to-mred queue-sexp-to-mred
+ send-sexp-to-mred send-sexp-to-mred/separate-thread queue-sexp-to-mred
  test
  wait-for-frame
  
@@ -52,7 +52,7 @@
 
 (module local-namespace racket/base
   (require racket/gui/base)
-  (provide send-sexp-to-mred
+  (provide send-sexp-to-mred send-sexp-to-mred/separate-thread
            queue-sexp-to-mred
            eof-result?
            shutdown-listener shutdown-mred mred-running?
@@ -76,6 +76,13 @@
           (eval sexp)))))
     (channel-get c))
 
+  (define (send-sexp-to-mred/separate-thread sexp)
+    (unless ns?
+      (namespace-require 'framework)
+      (namespace-require 'racket/gui/base)
+      (set! ns? #t))
+    (eval sexp))
+
   (define queue-sexp-to-mred send-sexp-to-mred)
 
   (define (eof-result? x)
@@ -120,7 +127,7 @@
            "debug.rkt"
            racket/tcp
            racket/pretty)
-  (provide send-sexp-to-mred
+  (provide send-sexp-to-mred send-sexp-to-mred/separate-thread
            queue-sexp-to-mred
            eof-result?
            shutdown-listener shutdown-mred mred-running?
@@ -272,6 +279,9 @@
                 [(normal) 
                  (eval (list-ref answer 1))]))))))
 
+  (define (send-sexp-to-mred/separate-thread sexp)
+    (send-sexp-to-mred sexp))
+
   (define queue-sexp-to-mred
     (lambda (sexp)
       (send-sexp-to-mred
@@ -319,7 +329,7 @@
              (define n (if use-local? l:n r:n))
              (choose ns ...))))]))
 
-(choose send-sexp-to-mred
+(choose send-sexp-to-mred send-sexp-to-mred/separate-thread
         queue-sexp-to-mred
         eof-result?
         shutdown-listener shutdown-mred mred-running?

gui-test/framework/tests/text.rkt

@@ -355,6 +355,98 @@
        (send t insert (new snip%) (send t last-position))
        (send t all-string-snips?)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  searching
+;;
+
+(define (search-test name setup-code expected-answer)
+  (test
+   name
+   (λ (x) (equal? x expected-answer))
+   (λ ()
+     (send-sexp-to-mred/separate-thread
+      `(let ()
+         (define answer (make-channel))
+         (queue-callback
+          (λ ()
+            (define t (new text:searching%))
+            ,setup-code
+            (let loop ()
+              (cond
+                [(send t search-updates-pending?)
+                 (queue-callback (λ () (loop)) #f)]
+                [else
+                 (define-values (before total) (send t get-search-hit-count))
+                 (channel-put answer (list before total))]))))
+         (channel-get answer))))))
+
+(search-test
+ 'search.1
+ `(begin (send t insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 1))
+
+(search-test
+ 'search.2
+ `(begin (send t insert "abc")
+         (send t set-position 3 3)
+         (send t set-searching-state "b" #f #f))
+ (list 1 1))
+
+(search-test
+ 'search.3
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t2 insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 3))
+
+(search-test
+ 'search.4
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position (send t last-position) (send t last-position))
+         (send t set-searching-state "b" #f #f))
+ (list 3 3))
+
+(search-test
+ 'search.5
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (define t3 (new text%))
+         (send t3 insert "abc")
+         (send t2 insert (new editor-snip% [editor t3]))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position (send t last-position) (send t last-position))
+         (send t set-searching-state "b" #f #f))
+ (list 5 5))
+
+(search-test
+ 'search.6
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (define t3 (new text%))
+         (send t3 insert "abc")
+         (send t2 insert (new editor-snip% [editor t3]))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 5))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  print-to-dc
@@ -620,3 +712,126 @@
            (flush-output port))
          (semaphore-wait clear-output-done)
          (send text get-text))))))
+
+(test
+ 'text:ports%.undo-does-not-remove-port-colors
+ (λ (x+y)
+   (equal? (list-ref x+y 0)
+           (list-ref x+y 1)))
+ (λ ()
+   (queue-sexp-to-mred
+    `(let ()
+       (define t (new (text:ports-mixin
+                       (editor:standard-style-list-mixin
+                        text:wide-snip%))))
+       
+       (send t set-max-undo-history 'forever)
+       (define last-undo? #f)
+       (send t add-undo (λ () (set! last-undo? #t)))
+       
+       (define vp (send t get-value-port))
+       (define op (send t get-out-port))
+       
+       (display "1" vp)
+       (display "2" op)
+       (flush-output vp)
+       (flush-output op)
+       
+       (define (to-vec c) (vector (send c red) (send c green) (send c blue)))
+       
+       (define (get-colors)
+         (let loop ([s (send t find-first-snip)])
+           (cond
+             [s (cons (list (send s get-text 0 (send s get-count))
+                            (to-vec (send (send s get-style) get-foreground)))
+                      (loop (send s next)))]
+             [else '()])))
+       
+       (define before (get-colors))
+       (let loop ()
+         (unless last-undo?
+           (send t undo)
+           (loop)))
+       (define after (get-colors))
+       (list before after)))))
+
+(define (test-ascii-art-enlarge-boxes-mixin name before position overwrite? chars after)
+  (test
+   name
+   (λ (got) (equal? got after))
+   (λ ()
+     (queue-sexp-to-mred
+      `(let ([t (new (text:ascii-art-enlarge-boxes-mixin text%))])
+         (send t set-ascii-art-enlarge #t)
+         (define f (new frame% [label ""]))
+         (define ec (new editor-canvas% [parent f] [editor t]))
+         (send t insert
+               ,before)
+         (send t set-position ,position ,position)
+         ,@(if overwrite? (list '(send t set-overwrite-mode #t)) '())
+         ,@(for/list ([char (in-list chars)])
+             `(send ec on-char (new key-event% [key-code ,char])))
+         (send t get-text))))))
+
+
+(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.1
+                                    (string-append
+                                     "╔═╦═╗\n"
+                                     "║ ║ ║\n"
+                                     "╠═╬═╣\n"
+                                     "║ ║ ║\n"
+                                     "╚═╩═╝\n")
+                                    7 #t '(#\a)
+                                    (string-append
+                                     "╔═╦═╗\n"
+                                     "║a║ ║\n"
+                                     "╠═╬═╣\n"
+                                     "║ ║ ║\n"
+                                     "╚═╩═╝\n"))
+
+(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.2
+                                    (string-append
+                                     "╔═╦═╗\n"
+                                     "║ ║ ║\n"
+                                     "╠═╬═╣\n"
+                                     "║ ║ ║\n"
+                                     "╚═╩═╝\n")
+                                    7 #t'(#\a #\b)
+                                    (string-append
+                                     "╔══╦═╗\n"
+                                     "║ab║ ║\n"
+                                     "╠══╬═╣\n"
+                                     "║  ║ ║\n"
+                                     "╚══╩═╝\n"))
+
+(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.3
+                                    (string-append
+                                     "╔═╦═╗\n"
+                                     "║ ║ ║\n"
+                                     "╠═╬═╣\n"
+                                     "║ ║ ║\n"
+                                     "╚═╩═╝\n")
+                                    7 #f '(#\a)
+                                    (string-append
+                                     "╔══╦═╗\n"
+                                     "║a ║ ║\n"
+                                     "╠══╬═╣\n"
+                                     "║  ║ ║\n"
+                                     "╚══╩═╝\n"))
+
+(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.4
+                                    (string-append
+                                     "╔═╦═╗\n"
+                                     "║ ║ ║\n"
+                                     "║ ║ ║\n"
+                                     "╠═╬═╣\n"
+                                     "║ ║ ║\n"
+                                     "╚═╩═╝\n")
+                                    14 #f '(#\f)
+                                    (string-append
+                                     "╔══╦═╗\n"
+                                     "║  ║ ║\n"
+                                     "║ f║ ║\n"
+                                     "╠══╬═╣\n"
+                                     "║  ║ ║\n"
+                                     "╚══╩═╝\n"))

gui-test/mrlib/tests/syntax-browser.rkt

@@ -0,0 +1,15 @@
+#lang racket/gui
+(require mrlib/syntax-browser rackunit)
+
+(let ()
+  (struct m ([x #:mutable]))
+  (define v (m 0))
+  (define stx (datum->syntax #'here v))
+  (set-m-x! v stx)
+  (define t (new text%))
+  (send t insert (render-syntax/snip stx))
+  (define bp (open-output-bytes))
+  (send t save-port bp)
+  (define t2 (new text%))
+  (send t2 insert-port (open-input-bytes (get-output-bytes bp)))
+  (check-regexp-match #rx"syntax-snip" (~s (send t2 find-first-snip))))

gui-test/tests/gracket/wxme.rkt

@@ -927,6 +927,18 @@
         #"")
 (expect (send fi2 ok?) #f)
 
+(let ()
+  (define (wash-it b)
+    (define out-base (new editor-stream-out-bytes-base%))
+    (define out-stream (make-object editor-stream-out% out-base))
+    (send out-stream put (bytes-length b) b)
+    (define bstr (send out-base get-bytes))
+    (define in-base (make-object editor-stream-in-bytes-base% bstr))
+    (define in-stream (make-object editor-stream-in% in-base))
+    (send in-stream get-unterminated-bytes))
+  (define ex-b #"object ...  ;;\351\232\234\347\242\215\347\211\251\345\210\227\350\241\250")
+  (expect (wash-it ex-b) ex-b))
+
 ;; ----------------------------------------
 ;; Save & load
 
@@ -1200,6 +1212,16 @@
 (expect (send km handle-key-event 'obj kevt) #t)
 (expect hit #\t)
 
+(let ()
+  (define k (new keymap%))
+  (send k add-function "swap if branches" void)
+  (send k map-function "c:x;r" "swap if branches")
+  (send k add-function "rectangle" void)
+  (expect (regexp-match? (regexp-quote "map-function in keymap%: \"r\" is already mapped as a non-prefix key")
+                         (with-handlers ([exn:fail? exn-message])
+                           (send k map-function "c:x;r;a" "rectangle")))
+          #t))
+
 ;; Chained keymap non-prefixed overrides prefixed
 (send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d)))
 (send km2 map-function "d" "letter-d")