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

Compare commits

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

3 Commits
master ... v6.5

Author SHA1 Message Date
Matthew Flatt
c843108e8d OS X: disable reordering of tabs in the new tab-panel% widget 
Fixes racket/drracket#52

(cherry picked from commit f0d10e9cc8)
 2016-04-18 09:50:02 -06:00
Matthew Flatt
c94fa35bc5 repair to work with ancient Gtk 
(cherry picked from commit 2fa9b94683)
 2016-04-17 14:32:47 -06:00
Matthew Flatt
bcfe618463 fix disable of tab-panel% with 'no-border 
(cherry picked from commit 6de1e4310c)
 2016-04-15 22:01:28 -06:00
49 changed files with 850 additions and 1830 deletions
Show Stats Expand all files Collapse all files

3
gui-doc/info.rkt
View File

@ -15,8 +15,7 @@
"gui-lib" "gui-lib"
"pict-lib" "pict-lib"
"racket-doc" "racket-doc"
"string-constants-doc" "string-constants-doc"))
"xrepl-doc"))
(define deps '("base")) (define deps '("base"))
(define update-implies '("gui-lib")) (define update-implies '("gui-lib"))

58
gui-doc/mrlib/scribblings/interactive-value-port.scrbl
View File

@ -6,53 +6,35 @@
@defmodule[mrlib/interactive-value-port] @defmodule[mrlib/interactive-value-port]
@defproc[(set-interactive-display-handler @defproc[(set-interactive-display-handler [port output-port?]) void?]{
[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 @racket[port-display-handler]) so that when it encounters these
these values: values:
@itemize[@item{syntax objects}
@item{snips}]
it uses @racket[write-special] to send snips to the port @itemize[
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.
If @racket[snip-handler] is not @racket[#f], then @item{exact, real, non-integral numbers}
@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].
To show values embedded in lists and other compound object, @item{syntax objects}
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 @defproc[(set-interactive-write-handler [port output-port?]) void?]{
[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 Like @racket[set-interactive-display-handler], but sets the
@racket[port-write-handler] and uses @racket[pretty-write].} @racket[port-write-handler].}
@defproc[(set-interactive-print-handler @defproc[(set-interactive-print-handler [port output-port?]) void?]{
[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 Like @racket[set-interactive-display-handler], but sets the
@racket[port-print-handler] and uses @racket[pretty-print].} @racket[port-print-handler].}

7
gui-doc/scribblings/framework/keymap.scrbl
View File

@ -19,12 +19,9 @@
@defmethod*[(((get-map-function-table/ht (ht hash?)) hash?))]{ @defmethod*[(((get-map-function-table/ht (ht hash?)) hash?))]{
This is a helper function for @method[keymap:aug-keymap<%> This is a helper function for @method[keymap:aug-keymap<%>
get-map-function-table] that returns a similar result, except it accepts a get-map-function-table] that returns the same result, except it accepts a
hash-table that it inserts the bindings into. It does not replace any hash-table that it inserts the bindings into. It does not replace any
bindings already in @racket[ht]. The result is different from bindings already in @racket[ht].
@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<%>)]{ @defmixin[keymap:aug-keymap-mixin (keymap%) (keymap:aug-keymap<%>)]{

16
gui-doc/scribblings/framework/racket.scrbl
View File

@ -84,22 +84,12 @@
} }
@defmethod[#:mode public-final @defmethod[#:mode public-final
(compute-racket-amount-to-indent (compute-racket-amount-to-indent [pos exact-nonnegative-integer?])
[pos exact-nonnegative-integer?]
[get-head-sexp-type
(-> string? (or/c #f 'lambda 'define 'begin 'for/fold 'other))
(λ (x) #f)])
exact-nonnegative-integer?]{ exact-nonnegative-integer?]{
Computes the amount of space to indent the line containing @racket[pos], Computes the amount of space to indent the line containing @racket[pos],
using the default s-expression indentation strategy. using the default s-expression indentation strategy.
The function @racket[get-head-sexp-type] is consulted for each symbol/keyword @history[#:added "1.9"]
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 @defmethod[#:mode augment
@ -258,7 +248,7 @@
} }
} }
@defmixin[racket:text-mixin @defmixin[racket:text-mixin
(text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>) (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>)
(racket:text<%>)]{ (racket:text<%>)]{
This mixin adds functionality for editing Racket files. This mixin adds functionality for editing Racket files.

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

@ -20,7 +20,7 @@
This function highlights a region of text in the buffer. This function highlights a region of text in the buffer.
The range between @racket[start] and @racket[end] will be highlighted with The range between @racket[start] and @racket[end] will be highlighted with
the given @racket[color], if the style is @racket['rectangle] (the default). If the color in color, if the style is @racket['rectangle] (the default). If
the style is @racket['ellipse], then an ellipse is drawn around the range 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], 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, then the outline of an ellipse is drawn around the range in the editor,
@ -268,39 +268,6 @@
preference changes. 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%)]{ @definterface[text:first-line<%> (text%)]{
Objects implementing this interface, when @method[text:first-line<%> Objects implementing this interface, when @method[text:first-line<%>

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

@ -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 @racket[x] and @racket[y] boxes are for the snip's bottom right
corner instead of its top-left corner. corner instead of its top-left corner.
Obtaining the @techlink{location} of the bottom-right corner may Obtaining the @techlink{location} if the bottom-right corner may
trigger delayed size calculations (including snips other than trigger delayed size calculations (including snips other than
the one whose @techlink{location} was requested). the one whose @techlink{location} was requested).
@ -2471,8 +2471,7 @@ See @xmethod[style-list% notify-on-change] for more information.
void?]{ void?]{
Undoes the last editor change, if undos have been enabled by calling Undoes the last editor change, if undos have been enabled by calling
@method[editor<%> set-max-undo-history] with a non-zero integer or @method[editor<%> set-max-undo-history] with a non-zero integer.
@racket['forever].
If the editor is currently performing an undo or redo, the method call If the editor is currently performing an undo or redo, the method call
is ignored. is ignored.
@ -2488,7 +2487,7 @@ The system may perform an undo without calling this method in response
to other method calls. Use methods such as to other method calls. Use methods such as
@method[editor<%> on-change] to monitor editor content changes. @method[editor<%> on-change] to monitor editor content changes.
See also @method[editor<%> add-undo]. See also @method[editor<%> add-undo] .
} }

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

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

30
gui-doc/scribblings/gui/init.scrbl
View File

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

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

@ -101,13 +101,9 @@ If @racket[try-chain?] is not @racket[#f], keymaps chained to this one
void?]{ void?]{
Chains @racket[next] off @this-obj[] The @racket[next] keymap will be Chains @racket[next] off @this-obj[] The @racket[next] keymap will be
used to handle events which are not handled by @this-obj[]. used to handle events which are not handled by @this-obj[]. If
@racket[prefix?] is a true value, then @racket[next] will take
If @racket[prefix?] is a true value, then @racket[next] will take precedence over other keymaps already chained to @this-obj[].
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% Multiple keymaps can be chained off one keymap using @method[keymap%
chain-to-keymap]. When keymaps are chained off a main keymap, events chain-to-keymap]. When keymaps are chained off a main keymap, events

15
gui-doc/scribblings/gui/panel-class.scrbl
View File

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

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

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

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

@ -183,14 +183,6 @@
(v) (v)
@{Recognizes the result of @racket[text:make-snip-special].}) @{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 (proc-doc/names
number-snip:make-repeating-decimal-snip number-snip:make-repeating-decimal-snip
(real? boolean? . -> . (is-a?/c snip%)) (real? boolean? . -> . (is-a?/c snip%))

14
gui-lib/framework/private/aspell.rkt
View File

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

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

@ -1119,29 +1119,6 @@
[define anchor-last-state? #f] [define anchor-last-state? #f]
[define overwrite-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)) (field (macro-recording? #f))
(define/private (update-macro-recording-icon) (define/private (update-macro-recording-icon)
(unless (eq? (send macro-recording-message is-shown?) (unless (eq? (send macro-recording-message is-shown?)
@ -1216,7 +1193,6 @@
(define/override (update-info) (define/override (update-info)
(super update-info) (super update-info)
(update-macro-recording-icon) (update-macro-recording-icon)
(update-ascii-art-enlarge-msg)
(overwrite-status-changed) (overwrite-status-changed)
(anchor-status-changed) (anchor-status-changed)
(editor-position-changed) (editor-position-changed)
@ -1257,11 +1233,6 @@
(send (get-info-panel) change-children (send (get-info-panel) change-children
(λ (l) (cons uncommon-parent (remq uncommon-parent l)))) (λ (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 (define anchor-message
(new message% (new message%
[font small-control-font] [font small-control-font]
@ -1283,7 +1254,6 @@
(define/private (add-uncommon-child c) (define/private (add-uncommon-child c)
(define (child->num c) (define (child->num c)
(cond (cond
[(eq? c ascii-art-enlarge-mode-msg) -1]
[(eq? c anchor-message) 0] [(eq? c anchor-message) 0]
[(eq? c overwrite-message) 1] [(eq? c overwrite-message) 1]
[(eq? c macro-recording-message) 2])) [(eq? c macro-recording-message) 2]))
@ -2083,13 +2053,10 @@
(let* ([string (get-text)] (let* ([string (get-text)]
[top-searching-edit (get-searching-text)]) [top-searching-edit (get-searching-text)])
(when top-searching-edit (when top-searching-edit
(let ([searching-edit (let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
(let loop ([txt top-searching-edit]) (if (and focus-snip (is-a? focus-snip editor-snip%))
(define focus-snip (send txt get-focus-snip)) (send focus-snip get-editor)
(cond top-searching-edit))]
[(and focus-snip (is-a? focus-snip editor-snip%))
(loop (send focus-snip get-editor))]
[else txt]))]
[not-found [not-found
(λ (found-edit skip-beep?) (λ (found-edit skip-beep?)

7
gui-lib/framework/private/gen-standard-menus.rkt
View File

@ -180,12 +180,7 @@
`(@defmethod[(,(between->name x) [menu (is-a?/c menu-item%)]) void?]{ `(@defmethod[(,(between->name x) [menu (is-a?/c menu-item%)]) void?]{
This method is called between the addition of the 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. @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) [(an-item? x)
`(@defmethod[(,(an-item->get-item-name x)) (or/c false/c (is-a?/c menu-item%))]{ `(@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 This method returns the @racket[menu-item%] object corresponding

30
gui-lib/framework/private/handler.rkt
View File

@ -173,23 +173,10 @@
;; install-recent-items : (is-a?/c menu%) -> void? ;; install-recent-items : (is-a?/c menu%) -> void?
(define (install-recent-items menu) (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 (define recently-opened-files
(preferences:get (preferences:get
'framework:recently-opened-files/pos)) '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 ([item (send menu get-items)]) (send item delete))
(for ([recent-list-item recently-opened-files]) (for ([recent-list-item recently-opened-files])
@ -201,7 +188,20 @@
(new menu-item% (new menu-item%
[parent menu] [parent menu]
[label (string-constant show-recent-items-window-menu-item)] [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) (define (recent-list-item->menu-label recent-list-item)
(let ([filename (car recent-list-item)]) (let ([filename (car recent-list-item)])

9
gui-lib/framework/private/interfaces.rkt
View File

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

353
gui-lib/framework/private/keymap-global.rkt
View File

@ -6,7 +6,6 @@
"interfaces.rkt" "interfaces.rkt"
"../preferences.rkt" "../preferences.rkt"
"gen-standard-menus.rkt" "gen-standard-menus.rkt"
"unicode-ascii-art.rkt"
(only-in srfi/13 string-prefix? string-prefix-length) (only-in srfi/13 string-prefix? string-prefix-length)
2d/dir-chars 2d/dir-chars
racket/list) racket/list)
@ -710,17 +709,6 @@
(when (= start (send txt get-end-position)) (when (= start (send txt get-end-position))
(widen-unicode-ascii-art-box txt start)))] (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 [center-in-unicode-ascii-art-box
(λ (txt evt) (λ (txt evt)
(define start (send txt get-start-position)) (define start (send txt get-start-position))
@ -752,8 +740,6 @@
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box) (add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
(add "widen-unicode-ascii-art-box" widen-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 "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box)
(add "shift-focus" (shift-focus values)) (add "shift-focus" (shift-focus values))
(add "shift-focus-backwards" (shift-focus reverse)) (add "shift-focus-backwards" (shift-focus reverse))
@ -850,9 +836,7 @@
(map "c:x;r;a" "normalize-unicode-ascii-art-box") (map "c:x;r;a" "normalize-unicode-ascii-art-box")
(map "c:x;r;w" "widen-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;c" "center-in-unicode-ascii-art-box")
(map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
(map "~m:c:\\" "TeX compress") (map "~m:c:\\" "TeX compress")
(map "~c:m:\\" "TeX compress") (map "~c:m:\\" "TeX compress")
@ -1043,6 +1027,166 @@
(f click-pos eol start-pos click-pos) (f click-pos eol start-pos click-pos)
(f click-pos eol click-pos end-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) (define/contract (run-some-keystrokes before key-evts)
(-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?) (-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?)
(listof (is-a?/c key-event%)) (listof (is-a?/c key-event%))
@ -1060,7 +1204,182 @@
(send t get-end-position))) (send t get-end-position)))
(module+ test (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) (check-equal? (run-some-keystrokes '("abc" 0 0)
(list (new key-event% [key-code 'escape]) (list (new key-event% [key-code 'escape])
(new key-event% [key-code #\c]))) (new key-event% [key-code #\c])))

33
gui-lib/framework/private/keymap.rkt
View File

@ -148,38 +148,7 @@
(hash-set! function-table (string->symbol keyname) fname)) (hash-set! function-table (string->symbol keyname) fname))
(define/public (get-map-function-table) (define/public (get-map-function-table)
(define table-possibly-with-prefixes (get-map-function-table/ht (make-hasheq))) (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) (define/public (get-map-function-table/ht table)
(for ([(keyname fname) (in-hash function-table)]) (for ([(keyname fname) (in-hash function-table)])

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

@ -25,8 +25,6 @@
(application-preferences-handler (λ () (preferences:show-dialog))) (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:color-scheme 'classic symbol?)
(preferences:set-default 'framework:column-guide-width (preferences:set-default 'framework:column-guide-width

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

@ -504,6 +504,12 @@
[else [else
(+ i 1)]))) (+ 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 (get-limit pos) 0)
(define/public (balance-parens key-event [smart-skip #f]) (define/public (balance-parens key-event [smart-skip #f])
@ -558,15 +564,11 @@
tab-char?)) tab-char?))
(define/pubment (compute-amount-to-indent pos) (define/pubment (compute-amount-to-indent pos)
(inner (compute-racket-amount-to-indent pos) 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 [_get-head-sexp-type (λ (x) #f)]) (define/public-final (compute-racket-amount-to-indent pos)
(cond (cond
[(is-stopped?) #f] [(is-stopped?) #f]
[else [else
(define get-head-sexp-type (define tabify-prefs (preferences:get 'framework:tabify))
(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 last-pos (last-position))
(define para (position-paragraph pos)) (define para (position-paragraph pos))
(define is-tabbable? (define is-tabbable?
@ -625,7 +627,8 @@
(let ([text (get-text contains id-end)]) (let ([text (get-text contains id-end)])
(cond (cond
[(member (classify-position contains) '(keyword symbol)) [(member (classify-position contains) '(keyword symbol))
(get-head-sexp-type text)] (or (get-keyword-type text tabify-prefs)
'other)]
[else [else
'other])))) 'other]))))
(define (procedure-indent) (define (procedure-indent)
@ -691,24 +694,18 @@
;; So far, the S-exp containing "pos" was all on ;; So far, the S-exp containing "pos" was all on
;; one line (possibly not counting the opening paren), ;; one line (possibly not counting the opening paren),
;; so indent to follow the first S-exp's end ;; so indent to follow the first S-exp's end
;; unless ;; unless there are just two sexps and the second is an ellipsis.
;; - there are just two sexps earlier and the second is an ellipsis. ;; in that case, we just ignore the 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 id-end (get-forward-sexp contains))
(define name-length (define name-length
(if id-end (if id-end
(- id-end contains) (- id-end contains)
0)) 0))
(cond (cond
[(or (first-sexp-is-keyword? contains) [(first-sexp-is-keyword? contains)
(sexp-is-all-hyphens? contains))
(visual-offset contains)] (visual-offset contains)]
[(second-sexp-is-ellipsis? contains) [(second-sexp-is-ellipsis? contains)
(visual-offset contains)] (visual-offset contains)]
[(sexp-is-all-hyphens? pos)
(visual-offset contains)]
[(not (find-up-sexp pos)) [(not (find-up-sexp pos))
(visual-offset contains)] (visual-offset contains)]
[else [else
@ -728,21 +725,6 @@
(visual-offset last))))])) (visual-offset last))))]))
amt-to-indent])) 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. ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
;; otherwise, returns #f ;; otherwise, returns #f
(define/private (second-sexp-is-ellipsis? contains) (define/private (second-sexp-is-ellipsis? contains)
@ -771,7 +753,6 @@
(unless (is-stopped?) (unless (is-stopped?)
(define first-para (position-paragraph start-pos)) (define first-para (position-paragraph start-pos))
(define end-para (position-paragraph end-pos)) (define end-para (position-paragraph end-pos))
(define tabifying-multiple-paras? (not (= first-para end-para)))
(with-handlers ([exn:break? (with-handlers ([exn:break?
(λ (x) #t)]) (λ (x) #t)])
(dynamic-wind (dynamic-wind
@ -782,14 +763,7 @@
(λ () (λ ()
(let loop ([para first-para]) (let loop ([para first-para])
(when (<= para end-para) (when (<= para end-para)
(define start (paragraph-start-position para)) (tabify (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)) (parameterize-break #t (void))
(loop (add1 para)))) (loop (add1 para))))
(when (and (>= (position-paragraph start-pos) end-para) (when (and (>= (position-paragraph start-pos) end-para)
@ -807,8 +781,8 @@
(when (< first-para end-para) (when (< first-para end-para)
(end-busy-cursor))))))) (end-busy-cursor)))))))
(define/public (tabify-all) (tabify-selection 0 (last-position))) (define (tabify-all) (tabify-selection 0 (last-position)))
(define/public (insert-return) (define (insert-return)
(begin-edit-sequence #t #f) (begin-edit-sequence #t #f)
(define end-of-whitespace (get-start-position)) (define end-of-whitespace (get-start-position))
(define start-cutoff (define start-cutoff
@ -832,7 +806,7 @@
new-pos)))) new-pos))))
(end-edit-sequence)) (end-edit-sequence))
(define/public (calc-last-para last-pos) (define (calc-last-para last-pos)
(let ([last-para (position-paragraph last-pos #t)]) (let ([last-para (position-paragraph last-pos #t)])
(if (and (> last-pos 0) (if (and (> last-pos 0)
(> last-para 0)) (> last-para 0))
@ -843,54 +817,56 @@
last-para))) last-para)))
last-para))) last-para)))
(define/public (comment-out-selection [start-pos (get-start-position)] (define comment-out-selection
[end-pos (get-end-position)]) (lambda ([start-pos (get-start-position)]
(begin-edit-sequence) [end-pos (get-end-position)])
(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) (begin-edit-sequence)
(split-snip start-pos) (let ([first-pos-is-first-para-pos?
(split-snip end-pos) (= (paragraph-start-position (position-paragraph start-pos))
(let* ([cb (instantiate comment-box:snip% ())] start-pos)])
[text (send cb get-editor)]) (let* ([first-para (position-paragraph start-pos)]
(let loop ([snip (find-snip start-pos 'after-or-none)]) [last-para (calc-last-para end-pos)])
(cond (let para-loop ([curr-para first-para])
[(not snip) (void)] (when (<= curr-para last-para)
[((get-snip-position snip) . >= . end-pos) (void)] (let ([first-on-para (paragraph-start-position curr-para)])
[else (insert #\; first-on-para)
(send text insert (send snip copy) (para-loop (add1 curr-para))))))
(send text last-position) (when first-pos-is-first-para-pos?
(send text last-position)) (set-position
(loop (send snip next))])) (paragraph-start-position (position-paragraph (get-start-position)))
(delete start-pos end-pos) (get-end-position))))
(insert cb start-pos)
(set-position start-pos start-pos))
(end-edit-sequence) (end-edit-sequence)
#t)) #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 ;; uncomment-box/selection : -> void
;; uncomments a comment box, if the focus is inside one. ;; uncomments a comment box, if the focus is inside one.
;; otherwise, calls uncomment selection to uncomment ;; otherwise, calls uncomment selection to uncomment
@ -909,43 +885,44 @@
(end-edit-sequence) (end-edit-sequence)
#t) #t)
(define/public (uncomment-selection [start-pos (get-start-position)] (define uncomment-selection
[end-pos (get-end-position)]) (lambda ([start-pos (get-start-position)]
(let ([snip-before (find-snip start-pos 'before-or-none)] [end-pos (get-end-position)])
[snip-after (find-snip start-pos 'after-or-none)]) (let ([snip-before (find-snip start-pos 'before-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 ;; extract-contents : number (is-a?/c comment-box:snip%) -> void
;; copies the contents of the comment-box-snip out of the snip ;; copies the contents of the comment-box-snip out of the snip
@ -1023,12 +1000,13 @@
(set-position end-pos) (set-position end-pos)
(bell)) (bell))
#t)) #t))
(define/public (flash-forward-sexp start-pos) [define flash-forward-sexp
(let ([end-pos (get-forward-sexp start-pos)]) (λ (start-pos)
(if end-pos (let ([end-pos (get-forward-sexp start-pos)])
(flash-on end-pos (add1 end-pos)) (if end-pos
(bell)) (flash-on end-pos (add1 end-pos))
#t)) (bell))
#t))]
(define/public (get-backward-sexp start-pos) (define/public (get-backward-sexp start-pos)
(let* ([limit (get-limit start-pos)] (let* ([limit (get-limit start-pos)]
[end-pos (backward-match start-pos limit)] [end-pos (backward-match start-pos limit)]
@ -1047,82 +1025,89 @@
end-pos))) end-pos)))
;; can't go backward at all: ;; can't go backward at all:
#f))) #f)))
(define/public (flash-backward-sexp start-pos) [define flash-backward-sexp
(let ([end-pos (get-backward-sexp start-pos)]) (λ (start-pos)
(if end-pos (let ([end-pos (get-backward-sexp start-pos)])
(flash-on end-pos (add1 end-pos)) (if end-pos
(bell)) (flash-on end-pos (add1 end-pos))
#t)) (bell))
(define/public (backward-sexp start-pos) #t))]
(let ([end-pos (get-backward-sexp start-pos)]) [define backward-sexp
(if end-pos (λ (start-pos)
(set-position end-pos) (let ([end-pos (get-backward-sexp start-pos)])
(bell)) (if end-pos
#t)) (set-position end-pos)
(define/public (find-up-sexp start-pos) (bell))
(let* ([limit-pos (get-limit start-pos)] #t))]
[exp-pos [define find-up-sexp
(backward-containing-sexp start-pos limit-pos)]) (λ (start-pos)
(let* ([limit-pos (get-limit start-pos)]
[exp-pos
(backward-containing-sexp start-pos limit-pos)])
(if (and exp-pos (> exp-pos limit-pos)) (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/public (up-sexp start-pos) [define up-sexp
(let ([exp-pos (find-up-sexp start-pos)]) (λ (start-pos)
(if exp-pos (let ([exp-pos (find-up-sexp start-pos)])
(set-position exp-pos) (if exp-pos
(bell)) (set-position exp-pos)
#t)) (bell))
(define/public (find-down-sexp start-pos) #t))]
(let loop ([pos start-pos]) [define find-down-sexp
(let ([next-pos (get-forward-sexp pos)]) (λ (start-pos)
(if (and next-pos (> next-pos pos)) (let loop ([pos start-pos])
(let ([back-pos (let ([next-pos (get-forward-sexp pos)])
(backward-containing-sexp (sub1 next-pos) pos)]) (if (and next-pos (> next-pos pos))
(if (and back-pos (let ([back-pos
(> back-pos pos)) (backward-containing-sexp (sub1 next-pos) pos)])
back-pos (if (and back-pos
(loop next-pos))) (> back-pos pos))
#f)))) back-pos
(define/public (down-sexp start-pos) (loop next-pos)))
(let ([pos (find-down-sexp start-pos)]) #f))))]
(if pos [define down-sexp
(set-position pos) (λ (start-pos)
(bell)) (let ([pos (find-down-sexp start-pos)])
#t)) (if pos
(define/public (remove-parens-forward start-pos) (set-position pos)
(let* ([pos (skip-whitespace start-pos 'forward #f)] (bell))
[first-char (get-character pos)] #t))]
[paren? (or (char=? first-char #\() [define remove-parens-forward
(char=? first-char #\[) (λ (start-pos)
(char=? first-char #\{))] (let* ([pos (skip-whitespace start-pos 'forward #f)]
[closer (and paren? [first-char (get-character pos)]
(get-forward-sexp pos))]) [paren? (or (char=? first-char #\()
(if (and paren? closer) (char=? first-char #\[)
(begin (begin-edit-sequence #t #f) (char=? first-char #\{))]
(delete pos (add1 pos)) [closer (and paren?
(delete (- closer 2) (- closer 1)) (get-forward-sexp pos))])
(end-edit-sequence)) (if (and paren? closer)
(bell)) (begin (begin-edit-sequence #t #f)
#t)) (delete pos (add1 pos))
(delete (- closer 2) (- closer 1))
(end-edit-sequence))
(bell))
#t))]
(define/private (select-text f forward?) (define/private (select-text f forward?)
(define start-pos (get-start-position)) (define start-pos (get-start-position))
@ -1139,11 +1124,11 @@
(extend-position new-pos) (extend-position new-pos)
(bell)) (bell))
#t) #t)
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
(define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t)) [define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
(define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f)) [define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
(define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f)) [define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
(define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t)) [define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
(define/public (introduce-let-ans pos) (define/public (introduce-let-ans pos)
(dynamic-wind (dynamic-wind
@ -1289,9 +1274,10 @@
(for-each (λ (s) (insert s start-1)) snips-2/rev) (for-each (λ (s) (insert s start-1)) snips-2/rev)
(set-position end-2) (set-position end-2)
(end-edit-sequence))))))))))) (end-edit-sequence)))))))))))
(define tab-size 8) [define tab-size 8]
(define/public (get-tab-size) tab-size) (public get-tab-size set-tab-size)
(define/public (set-tab-size s) (set! tab-size s)) [define get-tab-size (λ () tab-size)]
[define set-tab-size (λ (s) (set! tab-size s))]
(define/override (get-start-of-line pos) (define/override (get-start-of-line pos)
(define para (position-paragraph pos)) (define para (position-paragraph pos))
@ -1359,7 +1345,7 @@
(cond (cond
[(and (eq? type 'symbol) [(and (eq? type 'symbol)
(string? lexeme) (string? lexeme)
(get-head-sexp-type-from-prefs lexeme tabify-pref)) (get-keyword-type lexeme tabify-pref))
(values lexeme 'keyword paren start end backup-delta new-mode)] (values lexeme 'keyword paren start end backup-delta new-mode)]
[else [else
(values lexeme type paren start end backup-delta new-mode)])) (values lexeme type paren start end backup-delta new-mode)]))
@ -1378,9 +1364,9 @@
(|[| |]|) (|[| |]|)
(|{| |}|)))))) (|{| |}|))))))
;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp) ;; get-keyword-type : string (list ht regexp regexp regexp)
;; -> (or/c #f 'lambda 'define 'begin 'for/fold) ;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-head-sexp-type-from-prefs text pref) (define (get-keyword-type text pref)
(define ht (car pref)) (define ht (car pref))
(define beg-reg (list-ref pref 1)) (define beg-reg (list-ref pref 1))
(define def-reg (list-ref pref 2)) (define def-reg (list-ref pref 2))

207
gui-lib/framework/private/search.rkt
View File

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

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

@ -182,7 +182,6 @@
(define-signature text-class^ (define-signature text-class^
(basic<%> (basic<%>
line-spacing<%> line-spacing<%>
ascii-art-enlarge-boxes<%>
first-line<%> first-line<%>
line-numbers<%> line-numbers<%>
foreground-color<%> foreground-color<%>
@ -226,7 +225,6 @@
basic-mixin basic-mixin
line-spacing-mixin line-spacing-mixin
ascii-art-enlarge-boxes-mixin
first-line-mixin first-line-mixin
line-numbers-mixin line-numbers-mixin
foreground-color-mixin foreground-color-mixin
@ -261,8 +259,7 @@
range-color range-color
make-snip-special make-snip-special
snip-special? snip-special?))
send-snip-to-port))
(define-signature canvas-class^ (define-signature canvas-class^
(basic<%> (basic<%>

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

@ -12,11 +12,9 @@
"autocomplete.rkt" "autocomplete.rkt"
mred/mred-sig mred/mred-sig
mrlib/interactive-value-port mrlib/interactive-value-port
(prefix-in image-core: mrlib/image-core)
racket/list racket/list
"logging-timer.rkt" "logging-timer.rkt"
"coroutine.rkt" "coroutine.rkt"
"unicode-ascii-art.rkt"
data/queue data/queue
racket/unit) racket/unit)
@ -871,89 +869,6 @@
(super-new))) (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<%> (define foreground-color<%>
(interface (basic<%> editor:standard-style-list<%>) (interface (basic<%> editor:standard-style-list<%>)
@ -1222,7 +1137,7 @@
get-start-position get-end-position get-start-position get-end-position
unhighlight-ranges/key unhighlight-range highlight-range unhighlight-ranges/key unhighlight-range highlight-range
run-after-edit-sequence begin-edit-sequence end-edit-sequence run-after-edit-sequence begin-edit-sequence end-edit-sequence
find-string find-string-embedded get-admin position-line find-string get-admin position-line
in-edit-sequence? get-pos/text-dc-location in-edit-sequence? get-pos/text-dc-location
get-canvas get-top-level-window) get-canvas get-top-level-window)
@ -1352,16 +1267,16 @@
(when to-replace-highlight (when to-replace-highlight
(unhighlight-replace))] (unhighlight-replace))]
[else [else
(define next (do-search (get-start-position))) (define next (do-search (get-start-position) 'eof))
(begin-edit-sequence #t #f) (begin-edit-sequence #t #f)
(cond (cond
[(number? next) [next
(unless (and to-replace-highlight (unless (and to-replace-highlight
(= (car to-replace-highlight) next) (= (car to-replace-highlight) next)
(= (cdr to-replace-highlight) (= (cdr to-replace-highlight)
(string-length searching-str))) (+ next (string-length searching-str))))
(replace-highlight->normal-hit) (replace-highlight->normal-hit)
(define pr (cons next (string-length searching-str))) (define pr (cons next (+ next (string-length searching-str))))
(unhighlight-hit pr) (unhighlight-hit pr)
(highlight-replace pr))] (highlight-replace pr))]
[else [else
@ -1378,28 +1293,17 @@
(queue-callback (queue-callback
(λ () (λ ()
(when searching-str (when searching-str
(define start-pos (get-focus-editor-start-position)) (define count 0)
(define count (define start-pos (get-start-position))
(for/sum ([(k v) (in-hash search-bubble-table)]) (hash-for-each
(define n (if (search-result-compare <= (car k) start-pos) 1 0)) search-bubble-table
n)) (λ (k v)
(when (<= (car k) start-pos)
(set! count (+ count 1)))))
(update-before-caret-search-hit-count count)) (update-before-caret-search-hit-count count))
(set! search-position-callback-running? #f)) (set! search-position-callback-running? #f))
#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) (define/private (update-before-caret-search-hit-count c)
(unless (equal? before-caret-search-hit-count c) (unless (equal? before-caret-search-hit-count c)
(set! before-caret-search-hit-count c) (set! before-caret-search-hit-count c)
@ -1425,7 +1329,7 @@
(clear-yellow) (clear-yellow)
(set! clear-yellow void) (set! clear-yellow void)
(when (and searching-str (= (string-length searching-str) (- end start))) (when (and searching-str (= (string-length searching-str) (- end start)))
(when (find-string searching-str 'forward start end #t case-sensitive?) (when (do-search start end)
(set! clear-yellow (highlight-range (set! clear-yellow (highlight-range
start end start end
(if (preferences:get 'framework:white-on-black?) (if (preferences:get 'framework:white-on-black?)
@ -1444,7 +1348,7 @@
(list (list to-replace-highlight 'dark-search-color)) (list (list to-replace-highlight 'dark-search-color))
(list)) (list))
(hash-map search-bubble-table (hash-map search-bubble-table
(λ (x _true) (λ (x true)
(list x (if replace-mode? 'light-search-color 'normal-search-color))))) (list x (if replace-mode? 'light-search-color 'normal-search-color)))))
string<? string<?
#:key (λ (x) (format "~s" (car x))))) #:key (λ (x) (format "~s" (car x)))))
@ -1509,40 +1413,31 @@
[searching-str [searching-str
(define new-search-bubbles '()) (define new-search-bubbles '())
(define new-replace-bubble #f) (define new-replace-bubble #f)
(define first-hit (do-search 0)) (define first-hit (do-search 0 'eof))
(define-values (this-search-hit-count this-before-caret-search-hit-count) (define-values (this-search-hit-count this-before-caret-search-hit-count)
(cond (cond
[first-hit [first-hit
(define sp (get-focus-editor-start-position)) (define sp (get-start-position))
(let loop ([bubble-start first-hit] (let loop ([bubble-start first-hit]
[search-hit-count 0] [search-hit-count 0]
[before-caret-search-hit-count (if (search-result-compare < first-hit sp) 1 0)]) [before-caret-search-hit-count 1])
(maybe-pause) (maybe-pause)
(define bubble-end (search-result+ bubble-start (string-length searching-str))) (define bubble-end (+ bubble-start (string-length searching-str)))
(define bubble (cons bubble-start (string-length searching-str))) (define bubble (cons bubble-start bubble-end))
(define this-bubble (define this-bubble
(cond (cond
[(and replace-mode? [(and replace-mode?
(not new-replace-bubble) (not new-replace-bubble)
(search-result-compare <= sp bubble-start)) (<= sp bubble-start))
(set! new-replace-bubble bubble) (set! new-replace-bubble bubble)
'the-replace-bubble] 'the-replace-bubble]
[else [else
bubble])) bubble]))
(set! new-search-bubbles (cons this-bubble new-search-bubbles)) (set! new-search-bubbles (cons this-bubble new-search-bubbles))
(define next (do-search bubble-end)) (define next (do-search bubble-end 'eof))
(when (> (let loop ([x bubble-start])
(cond
[(number? x) 1]
[else (+ 1 (loop (cdr x)))]))
3)
(car))
(define next-before-caret-search-hit-count (define next-before-caret-search-hit-count
(if (and next (search-result-compare < next sp)) (if (and next (< next sp))
(+ 1 before-caret-search-hit-count) (+ 1 before-caret-search-hit-count)
before-caret-search-hit-count)) before-caret-search-hit-count))
(cond (cond
@ -1593,81 +1488,14 @@
[(is-a? w area<%>) [(is-a? w area<%>)
(loop (send w get-parent))])))))) (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) (define/private (clear-all-regions)
(when to-replace-highlight (when to-replace-highlight
(unhighlight-replace)) (unhighlight-replace))
(for ([(txt _) (in-hash all-txt-with-regions-to-clear)]) (unhighlight-ranges/key 'plt:framework:search-bubbles)
(send txt unhighlight-ranges/key 'plt:framework:search-bubbles))
(set! all-txt-with-regions-to-clear (make-hasheq))
(set! search-bubble-table (make-hash))) (set! search-bubble-table (make-hash)))
(define/private (do-search start) (define/private (do-search start end)
(define context (list this)) (find-string searching-str 'forward start end #t case-sensitive?))
(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, ;; INVARIANT: when a search bubble is highlighted,
;; the search-bubble-table has it mapped to #t ;; the search-bubble-table has it mapped to #t
@ -1677,61 +1505,40 @@
;; this method may be called with bogus inputs (ie a pair that has no highlight) ;; 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 ;; but only when there is a pending "erase all highlights and recompute everything" callback
(define/private (unhighlight-hit bubble) (define/private (unhighlight-hit pair)
(hash-remove! search-bubble-table bubble) (hash-remove! search-bubble-table pair)
(define-values (txt start end) (get-highlighting-text-and-range bubble)) (unhighlight-range (car pair) (cdr pair)
(when txt (if replace-mode? light-search-color normal-search-color)
(send txt unhighlight-range #f
start end 'hollow-ellipse))
(if replace-mode? light-search-color normal-search-color) (define/private (highlight-hit pair)
#f (hash-set! search-bubble-table pair #t)
'hollow-ellipse))) (highlight-range (car pair) (cdr pair)
(define/private (highlight-hit bubble) (if replace-mode? light-search-color normal-search-color)
(hash-set! search-bubble-table bubble #t) #f
(define-values (txt start end) (get-highlighting-text-and-range bubble)) 'low
(when txt 'hollow-ellipse
(hash-set! all-txt-with-regions-to-clear txt #t) #:key 'plt:framework:search-bubbles
(send txt highlight-range #:adjust-on-insert/delete? #t))
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 ;; INVARIANT: the "next to replace" highlight is always
;; saved in 'to-replace-highlight' ;; saved in 'to-replace-highlight'
(define/private (unhighlight-replace) (define/private (unhighlight-replace)
(define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight)) (unhighlight-range (car to-replace-highlight)
(when txt (cdr to-replace-highlight)
(send txt unhighlight-range dark-search-color
start end #f
dark-search-color 'hollow-ellipse)
#f
'hollow-ellipse))
(set! to-replace-highlight #f)) (set! to-replace-highlight #f))
(define/private (highlight-replace new-to-replace) (define/private (highlight-replace new-to-replace)
(set! to-replace-highlight new-to-replace) (set! to-replace-highlight new-to-replace)
(define-values (txt start end) (get-highlighting-text-and-range new-to-replace)) (highlight-range (car to-replace-highlight)
(when txt (cdr to-replace-highlight)
(send txt highlight-range dark-search-color
start end #f
dark-search-color 'high
#f 'hollow-ellipse))
'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) (define/private (unhighlight-anchor)
(unhighlight-range anchor-pos anchor-pos "red" #f 'dot) (unhighlight-range anchor-pos anchor-pos "red" #f 'dot)
@ -2463,29 +2270,22 @@
[the-snipclass [the-snipclass
(define base (new editor-stream-out-bytes-base%)) (define base (new editor-stream-out-bytes-base%))
(define stream (make-object editor-stream-out% base)) (define stream (make-object editor-stream-out% base))
(write-editor-global-header stream)
(send snip write stream) (send snip write stream)
(write-editor-global-footer stream)
(snip-special snip (snip-special snip
(send the-snipclass get-classname) (send the-snipclass get-classname)
(send base get-bytes))] (send base get-bytes))]
[else [else
(snip-special snip #f #f)])) (snip-special snip #f #f)]))
;; -> (or/c (is-a?/c snip%) exn:fail?)
(define (snip-special->snip snip-special) (define (snip-special->snip snip-special)
(define the-name (snip-special-name snip-special)) (define the-name (snip-special-name snip-special))
(define snipclass (and the-name (send (get-the-snip-class-list) find the-name))) (define snipclass (and the-name (send (get-the-snip-class-list) find the-name)))
(cond (cond
[snipclass [snipclass
(with-handlers ([exn:fail? values]) (define base (make-object editor-stream-in-bytes-base%
(define base (make-object editor-stream-in-bytes-base% (snip-special-bytes snip-special)))
(snip-special-bytes snip-special))) (define es (make-object editor-stream-in% base))
(define es (make-object editor-stream-in% base)) (or (send snipclass read es)
(read-editor-global-header es) (snip-special-snip snip-special))]
(define the-snip (send snipclass read es))
(read-editor-global-footer es)
(or the-snip
(snip-special-snip snip-special)))]
[else [else
(snip-special-snip snip-special)])) (snip-special-snip snip-special)]))
@ -2839,7 +2639,7 @@
(define/private (do-insertion txts showing-input?) (define/private (do-insertion txts showing-input?)
(define locked? (is-locked?)) (define locked? (is-locked?))
(define sf? (get-styles-fixed)) (define sf? (get-styles-fixed))
(begin-edit-sequence #f) (begin-edit-sequence)
(lock #f) (lock #f)
(set-styles-fixed #f) (set-styles-fixed #f)
(set! allow-edits? #t) (set! allow-edits? #t)
@ -2848,26 +2648,12 @@
[(null? txts) (void)] [(null? txts) (void)]
[else [else
(define fst (car txts)) (define fst (car txts))
(define-values (str/snp style) (define str/snp
(cond (cond
[(snip-special? (car fst)) [(snip-special? (car fst))
(define the-snip (snip-special->snip (car fst))]
(snip-special->snip (car fst))) [else (car fst)]))
(if (exn:fail? the-snip) (define style (cdr fst))
(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 (define inserted-count
(if (is-a? str/snp snip%) (if (is-a? str/snp snip%)
@ -3075,8 +2861,8 @@
;; don't want to set the port-print-handler here; ;; don't want to set the port-print-handler here;
;; instead drracket sets the global-port-print-handler ;; instead drracket sets the global-port-print-handler
;; to catch fractions and the like ;; to catch fractions and the like
(set-interactive-write-handler port #:snip-handler send-snip-to-port) (set-interactive-write-handler port)
(set-interactive-display-handler port #:snip-handler send-snip-to-port))]) (set-interactive-display-handler port))])
(install-handlers out-port) (install-handlers out-port)
(install-handlers err-port) (install-handlers err-port)
(install-handlers value-port)))) (install-handlers value-port))))
@ -3215,30 +3001,6 @@
(define in-port (make-in-port-with-a-name (get-port-name))) (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 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<%> (define input-box<%>
(interface ((class->interface text%)) (interface ((class->interface text%))
)) ))

450
gui-lib/framework/private/unicode-ascii-art.rkt
View File

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

4
gui-lib/info.rkt
View File

@ -4,7 +4,7 @@
(define deps '("srfi-lite-lib" (define deps '("srfi-lite-lib"
"data-lib" "data-lib"
["base" #:version "6.5.0.2"] ["base" #:version "6.4"]
"syntax-color-lib" "syntax-color-lib"
["draw-lib" #:version "1.13"] ["draw-lib" #:version "1.13"]
["snip-lib" #:version "1.2"] ["snip-lib" #:version "1.2"]
@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby)) (define pkg-authors '(mflatt robby))
(define version "1.28") (define version "1.24")

2
gui-lib/mred/info.rkt
View File

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

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

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

21
gui-lib/mred/private/mrpanel.rkt
View File

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

6
gui-lib/mred/private/wx/cocoa/window.rkt
View File

@ -621,13 +621,11 @@
(define enabled? #t) (define enabled? #t)
(define/public (is-enabled-to-root?) (define/public (is-enabled-to-root?)
(and (is-window-enabled?/raw) (is-parent-enabled-to-root?))) (and (is-window-enabled?) (is-parent-enabled-to-root?)))
(define/public (is-parent-enabled-to-root?) (define/public (is-parent-enabled-to-root?)
(send parent is-enabled-to-root?)) (send parent is-enabled-to-root?))
(define/public (is-window-enabled?/raw)
enabled?)
(define/public (is-window-enabled?) (define/public (is-window-enabled?)
(is-window-enabled?/raw)) enabled?)
(define/public (enable on?) (define/public (enable on?)
(atomically (atomically
(set! enabled? on?) (set! enabled? on?)

2
gui-lib/mred/private/wxme/keymap.rkt
View File

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

9
gui-lib/mred/private/wxme/stream.rkt
View File

@ -381,15 +381,6 @@
(unless recur? (inc-item-count)) (unless recur? (inc-item-count))
(let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)]) (let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)])
(read si))]) (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) (if (or (not s)
(not (eof-object? (read-byte si)))) (not (eof-object? (read-byte si))))
(fail) (fail)

18
gui-lib/mred/private/wxpanel.rkt
View File

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

7
gui-lib/mrlib/image-core.rkt
View File

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

38
gui-lib/mrlib/interactive-value-port.rkt
View File

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

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

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

2
gui-lib/racket/gui/info.rkt
View File

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

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

@ -1,47 +1,32 @@
#lang racket/base #lang racket/base
(require launcher (require launcher
racket/path racket/path
racket/file racket/file)
setup/dirs)
(provide installer) (provide post-installer)
(define (installer path coll user? no-main?) (define (post-installer path collection user?)
(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 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) ;; add a gracket-text executable that uses the -z flag (preferring a script)
(for ([vs '((script-3m 3m) (script-cgc cgc))]) (for ([vs '((script-3m 3m) (script-cgc cgc))])
(let ([v (findf (lambda (v) (memq v variants)) vs)]) (let ([v (findf (lambda (v) (memq v variants)) vs)])
(when v (when v
(parameterize ([current-launcher-variant v]) (parameterize ([current-launcher-variant v])
(make-mred-launcher (make-mred-launcher
#:tether-mode tether-mode
'("-z") '("-z")
(prep-dir (prep-dir
(mred-program-launcher-path "gracket-text" #:user? user? #:tethered? tethered?)) (mred-program-launcher-path "gracket-text" #:user? user?))
`([subsystem . console] `([subsystem . console] [single-instance? . #f]
[single-instance? . #f] [relative? . ,(not user?)]))))))
[relative? . ,(not (or user? tethered?))]))))))
;; add a bin/gracket (in addition to lib/gracket) ;; add a bin/gracket (in addition to lib/gracket)
(for ([vs '((script-3m 3m) (script-cgc cgc))]) (for ([vs '((script-3m 3m) (script-cgc cgc))])
(let ([v (findf (lambda (v) (memq v variants)) vs)]) (let ([v (findf (lambda (v) (memq v variants)) vs)])
(when v (when v
(parameterize ([current-launcher-variant v]) (parameterize ([current-launcher-variant v])
(make-mred-launcher #:tether-mode tether-mode (make-mred-launcher null
null
(prep-dir (prep-dir
(mred-program-launcher-path "GRacket" #:user? user? #:tethered? tethered?)) (mred-program-launcher-path "GRacket" #:user? user?))
`([exe-name . "GRacket"] '([exe-name . "GRacket"] [relative? . ,(not user?)]
[relative? . ,(not (or user? tethered?))]
[exe-is-gracket . #t]))))))) [exe-is-gracket . #t])))))))
(define (prep-dir p) (define (prep-dir p)

7
gui-lib/racket/gui/interactive.rkt
View File

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

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

@ -128,6 +128,8 @@
(queue-callback (queue-callback
(λ () (λ ()
(send (test:get-active-top-level-window) close))) (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)) editor-contents))
test-file-contents test-file-contents
name)) name))
@ -136,19 +138,9 @@
(test-open "frame:searchable open" frame:searchable%) (test-open "frame:searchable open" frame:searchable%)
(test-open "frame:text open" frame:text%)) (test-open "frame:text open" frame:text%))
(let ([pref-ht (make-hash)]) (parameterize ([test:use-focus-table #t])
(parameterize ([test:use-focus-table #t] (define dummy (make-object frame:basic% "dummy to keep from quitting"))
[preferences:low-level-get-preference (send dummy show #t)
(λ (sym [fail (λ () #f)]) (creation-tests)
(hash-ref pref-ht sym fail))] (open-tests)
[preferences:low-level-put-preferences (send dummy show #f))
(λ (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)))

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

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

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

@ -90,26 +90,6 @@
string<? string<?
#:key (lambda (x) (format "~s" x))))))) #: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) (define (test-canonicalize name str1 str2)
(test (test
(string->symbol (format "keymap:canonicalize-keybinding-string/~a" name)) (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))

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

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

4
gui-test/framework/tests/racket.rkt
View File

@ -175,10 +175,6 @@
"(#:x\n 1)") "(#:x\n 1)")
(test-indentation "(#:x 0\n1)" (test-indentation "(#:x 0\n1)"
"(#:x 0\n 1)") "(#: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) (define (test-magic-square-bracket which before after)

24
gui-test/framework/tests/search.rkt
View File

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

18
gui-test/framework/tests/test-suite-utils.rkt
View File

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

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

@ -355,98 +355,6 @@
(send t insert (new snip%) (send t last-position)) (send t insert (new snip%) (send t last-position))
(send t all-string-snips?))))) (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 ;; print-to-dc
@ -712,126 +620,3 @@
(flush-output port)) (flush-output port))
(semaphore-wait clear-output-done) (semaphore-wait clear-output-done)
(send text get-text)))))) (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"))

15
gui-test/mrlib/tests/syntax-browser.rkt
View File

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

22
gui-test/tests/gracket/wxme.rkt
View File

@ -927,18 +927,6 @@
#"") #"")
(expect (send fi2 ok?) #f) (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 ;; Save & load
@ -1212,16 +1200,6 @@
(expect (send km handle-key-event 'obj kevt) #t) (expect (send km handle-key-event 'obj kevt) #t)
(expect hit #\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 ;; Chained keymap non-prefixed overrides prefixed
(send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d))) (send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d)))
(send km2 map-function "d" "letter-d") (send km2 map-function "d" "letter-d")