Compare commits
3 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
c843108e8d | ||
|
|
c94fa35bc5 | ||
|
|
bcfe618463 |
|
|
@ -15,8 +15,7 @@
|
|||
"gui-lib"
|
||||
"pict-lib"
|
||||
"racket-doc"
|
||||
"string-constants-doc"
|
||||
"xrepl-doc"))
|
||||
"string-constants-doc"))
|
||||
(define deps '("base"))
|
||||
(define update-implies '("gui-lib"))
|
||||
|
||||
|
|
|
|||
|
|
@ -6,53 +6,35 @@
|
|||
@defmodule[mrlib/interactive-value-port]
|
||||
|
||||
|
||||
@defproc[(set-interactive-display-handler
|
||||
[port output-port?]
|
||||
[#:snip-handler snip-handler
|
||||
(or/c #f (-> (is-a?/c snip%) output-port? any))
|
||||
#f])
|
||||
void?]{
|
||||
@defproc[(set-interactive-display-handler [port output-port?]) void?]{
|
||||
|
||||
Sets @racket[port]'s display handler (via
|
||||
@racket[port-display-handler]) so that when it encounters
|
||||
these values:
|
||||
@itemize[@item{syntax objects}
|
||||
@item{snips}]
|
||||
Sets @racket[port]'s display handler (via
|
||||
@racket[port-display-handler]) so that when it encounters these
|
||||
values:
|
||||
|
||||
it uses @racket[write-special] to send snips to the port
|
||||
and uses @racketmodname[mrlib/syntax-browser] to turn
|
||||
syntax object into snips and then uses
|
||||
@racket[write-special] with the result to send it to the
|
||||
port. Otherwise, it behaves like the default handler.
|
||||
@itemize[
|
||||
|
||||
@item{exact, real, non-integral numbers}
|
||||
|
||||
If @racket[snip-handler] is not @racket[#f], then
|
||||
@racket[set-interactive-display-handler] passes any snips
|
||||
to it (not those it creates by
|
||||
@racketmodname[mrlib/syntax-browser]) instead of calling
|
||||
@racket[write-special].
|
||||
@item{syntax objects}
|
||||
|
||||
To show values embedded in lists and other compound object,
|
||||
it uses @racket[pretty-display].
|
||||
}
|
||||
]
|
||||
|
||||
it uses @racket[write-special] to send snips to the port,
|
||||
instead of those values. Otherwise, it behaves like the
|
||||
default handler.
|
||||
|
||||
To show values embedded in lists and other compound object, it uses
|
||||
@racket[pretty-print].}
|
||||
|
||||
|
||||
@defproc[(set-interactive-write-handler
|
||||
[port output-port?]
|
||||
[#:snip-handler snip-handler
|
||||
(or/c #f (-> (is-a?/c snip%) output-port? any))
|
||||
#f])
|
||||
void?]{
|
||||
@defproc[(set-interactive-write-handler [port output-port?]) void?]{
|
||||
|
||||
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
|
||||
[port output-port?]
|
||||
[#:snip-handler snip-handler
|
||||
(or/c #f (-> (is-a?/c snip%) output-port? any))
|
||||
#f])
|
||||
void?]{
|
||||
@defproc[(set-interactive-print-handler [port output-port?]) void?]{
|
||||
|
||||
Like @racket[set-interactive-display-handler], but sets the
|
||||
@racket[port-print-handler] and uses @racket[pretty-print].}
|
||||
@racket[port-print-handler].}
|
||||
|
|
|
|||
|
|
@ -19,12 +19,9 @@
|
|||
|
||||
@defmethod*[(((get-map-function-table/ht (ht hash?)) hash?))]{
|
||||
This is a helper function for @method[keymap:aug-keymap<%>
|
||||
get-map-function-table] that returns 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
|
||||
bindings already in @racket[ht]. The result is different from
|
||||
@method[keymap:aug-keymap<%> get-map-function-table] only in that
|
||||
@racket[keymap:aug-keymap<%> get-map-function-table] will remove keybindings
|
||||
that are also have a prefix (since those keybindings are not active).
|
||||
bindings already in @racket[ht].
|
||||
}
|
||||
}
|
||||
@defmixin[keymap:aug-keymap-mixin (keymap%) (keymap:aug-keymap<%>)]{
|
||||
|
|
|
|||
|
|
@ -84,22 +84,12 @@
|
|||
}
|
||||
|
||||
@defmethod[#:mode public-final
|
||||
(compute-racket-amount-to-indent
|
||||
[pos exact-nonnegative-integer?]
|
||||
[get-head-sexp-type
|
||||
(-> string? (or/c #f 'lambda 'define 'begin 'for/fold 'other))
|
||||
(λ (x) #f)])
|
||||
(compute-racket-amount-to-indent [pos exact-nonnegative-integer?])
|
||||
exact-nonnegative-integer?]{
|
||||
Computes the amount of space to indent the line containing @racket[pos],
|
||||
using the default s-expression indentation strategy.
|
||||
|
||||
The function @racket[get-head-sexp-type] is consulted for each symbol/keyword
|
||||
that follows an open parenthesis. If it returns @racket[#f], then the
|
||||
user's preferences (from the @onscreen{Indenting} panel of the @onscreen{Editing}
|
||||
panel in the preferences dialog) are used.
|
||||
|
||||
@history[#:added "1.9"
|
||||
#:changed "1.26" @list{Added the @racket[get-head-sexp-type] argument.}]
|
||||
@history[#:added "1.9"]
|
||||
}
|
||||
|
||||
@defmethod[#:mode augment
|
||||
|
|
@ -258,7 +248,7 @@
|
|||
}
|
||||
}
|
||||
@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<%>)]{
|
||||
This mixin adds functionality for editing Racket files.
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
This function highlights a region of text in the buffer.
|
||||
|
||||
The range between @racket[start] and @racket[end] will be highlighted with
|
||||
the 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
|
||||
in the editor, using the color. If the style is @racket['hollow-ellipse],
|
||||
then the outline of an ellipse is drawn around the range in the editor,
|
||||
|
|
@ -268,39 +268,6 @@
|
|||
preference changes.
|
||||
}
|
||||
|
||||
@definterface[text:ascii-art-enlarge-boxes<%> ()]{
|
||||
@defmethod[(set-ascii-art-enlarge [e? any/c]) void?]{
|
||||
Enables or disables the ascii art box enlarging mode based on @racket[e?]'s true value.
|
||||
}
|
||||
@defmethod[(get-ascii-art-enlarge) boolean?]{
|
||||
Returns @racket[#t] if ascii art box enlarging mode is enabled and @racket[#f] otherwise.
|
||||
}
|
||||
}
|
||||
|
||||
@defmixin[text:ascii-art-enlarge-boxes-mixin (text%) (text:ascii-art-enlarge-boxes<%>)]{
|
||||
@defmethod[#:mode override (on-local-char [event (is-a?/c key-event%)]) void?]{
|
||||
When the @method[key-event% get-key-code] method of @racket[event] returns either
|
||||
@racket['numpad-enter] or @racket[#\return] and
|
||||
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
|
||||
@racket[#t], this method handles
|
||||
the return key by adding an additional line in the containing unicode ascii art
|
||||
box and moving the insertion point to the first character on the new line that
|
||||
is in the containing cell.
|
||||
|
||||
It does not call the @racket[super] method (in that case).
|
||||
}
|
||||
@defmethod[#:mode override (on-default-char [event (is-a?/c key-event%)]) void?]{
|
||||
When the @method[key-event% get-key-code] method of @racket[event] returns either
|
||||
a character or symbol that corresponds to the insertion of a single character
|
||||
@method[text:ascii-art-enlarge-boxes<%> get-ascii-art-enlarge] returns
|
||||
@racket[#t], this method first makes room in the box and then calls the
|
||||
@racket[super] method. If the @method[text% get-overwrite-mode] returns
|
||||
@racket[#f], then it always opens up a column in the box. If @method[text% get-overwrite-mode]
|
||||
returns @racket[#t], then it opens up a column only when the character to
|
||||
be inserted would overwrite one of the walls.
|
||||
}
|
||||
}
|
||||
|
||||
@definterface[text:first-line<%> (text%)]{
|
||||
|
||||
Objects implementing this interface, when @method[text:first-line<%>
|
||||
|
|
|
|||
|
|
@ -871,7 +871,7 @@ If @racket[bottom-right?] is not @racket[#f], the values in the
|
|||
@racket[x] and @racket[y] boxes are for the snip's bottom right
|
||||
corner instead of its top-left corner.
|
||||
|
||||
Obtaining the @techlink{location} of the bottom-right corner may
|
||||
Obtaining the @techlink{location} if the bottom-right corner may
|
||||
trigger delayed size calculations (including snips other than
|
||||
the one whose @techlink{location} was requested).
|
||||
|
||||
|
|
@ -2471,8 +2471,7 @@ See @xmethod[style-list% notify-on-change] for more information.
|
|||
void?]{
|
||||
|
||||
Undoes the last editor change, if undos have been enabled by calling
|
||||
@method[editor<%> set-max-undo-history] with a non-zero integer or
|
||||
@racket['forever].
|
||||
@method[editor<%> set-max-undo-history] with a non-zero integer.
|
||||
|
||||
If the editor is currently performing an undo or redo, the method call
|
||||
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
|
||||
@method[editor<%> on-change] to monitor editor content changes.
|
||||
|
||||
See also @method[editor<%> add-undo].
|
||||
See also @method[editor<%> add-undo] .
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@ Both parts of the toolbox rely extensively on the
|
|||
@include-section["prefs.scrbl"]
|
||||
@include-section["dynamic.scrbl"]
|
||||
@include-section["startup.scrbl"]
|
||||
@include-section["init.scrbl"]
|
||||
@include-section["libs.scrbl"]
|
||||
|
||||
@;------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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"]}
|
||||
|
|
@ -101,13 +101,9 @@ If @racket[try-chain?] is not @racket[#f], keymaps chained to this one
|
|||
void?]{
|
||||
|
||||
Chains @racket[next] off @this-obj[] The @racket[next] keymap will be
|
||||
used to handle events which are not handled by @this-obj[].
|
||||
|
||||
If @racket[prefix?] is a true value, then @racket[next] will take
|
||||
precedence over other keymaps already chained to @this-obj[] 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?].
|
||||
used to handle events which are not handled by @this-obj[]. If
|
||||
@racket[prefix?] is a true value, then @racket[next] will take
|
||||
precedence over other keymaps already chained to @this-obj[].
|
||||
|
||||
Multiple keymaps can be chained off one keymap using @method[keymap%
|
||||
chain-to-keymap]. When keymaps are chained off a main keymap, events
|
||||
|
|
|
|||
|
|
@ -24,8 +24,8 @@ A @racket[panel%] object has a degenerate placement strategy for
|
|||
@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
|
||||
(is-a?/c panel%) (is-a?/c pane%))]
|
||||
[style (listof (or/c 'border 'deleted
|
||||
'hscroll 'auto-hscroll 'hide-hscroll
|
||||
'vscroll 'auto-vscroll 'hide-vscroll)) null]
|
||||
'hscroll 'auto-hscroll
|
||||
'vscroll 'auto-vscroll)) null]
|
||||
[enabled any/c #t]
|
||||
[vert-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's own size in the corresponding direction is not
|
||||
constrained by the size of its children subareas. The @racket['auto-hscroll]
|
||||
and @racket['auto-vscroll] styles imply @racket['hscroll] and
|
||||
@racket['vscroll], respectively, but they cause the corresponding scrollbar to
|
||||
and @racket['auto-vscroll] styles are like @racket['hscroll] or
|
||||
@racket['vscroll], but they cause the corresponding scrollbar to
|
||||
disappear when no scrolling is needed in the corresponding direction;
|
||||
the @racket['auto-vscroll] and @racket['auto-hscroll] modes assume that
|
||||
children subareas are placed using the default algorithm for a @racket[panel%],
|
||||
@racket[vertical-panel%], or @racket[horizontal-panel%]. The @racket['hide-hscroll]
|
||||
and @racket['hide-vscroll] styles imply @racket['auto-hscroll] and
|
||||
@racket['auto-vscroll], respectively, but the corresponding scroll bar is never
|
||||
made visible (while still allowing the panel content to exceed its own size).
|
||||
@racket[vertical-panel%], or @racket[horizontal-panel%].
|
||||
|
||||
@WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
|
||||
|
||||
@history[#:changed "1.25" @elem{Added @racket['hide-vscroll] and @racket['hide-hscroll].}]}}
|
||||
}}
|
||||
|
||||
|
|
|
|||
|
|
@ -998,7 +998,7 @@ animation frame with @method[canvas<%> suspend-flush] and
|
|||
are not flushed to the screen. Use @method[canvas<%> flush] to ensure
|
||||
that canvas content is flushed when it is ready if a @method[canvas<%>
|
||||
suspend-flush] will soon follow, because the process of flushing to
|
||||
the screen can be starved if flushing is frequently suspended. The
|
||||
the screen can be starved if flushing is frequently suspend. The
|
||||
method @xmethod[canvas% refresh-now] conveniently encapsulates this
|
||||
sequence.
|
||||
|
||||
|
|
|
|||
|
|
@ -183,14 +183,6 @@
|
|||
(v)
|
||||
@{Recognizes the result of @racket[text:make-snip-special].})
|
||||
|
||||
(proc-doc/names
|
||||
text:send-snip-to-port
|
||||
(-> (is-a?/c snip%) output-port? void?)
|
||||
(snip port)
|
||||
@{Sends @racket[snip] to @racket[port] by using @racket[text:make-snip-special],
|
||||
handling a few special cases for performance and backwards compatibility
|
||||
reasons.})
|
||||
|
||||
(proc-doc/names
|
||||
number-snip:make-repeating-decimal-snip
|
||||
(real? boolean? . -> . (is-a?/c snip%))
|
||||
|
|
|
|||
|
|
@ -95,7 +95,6 @@
|
|||
(define aspell-proc #f)
|
||||
(define already-attempted-aspell? #f)
|
||||
(define current-dict #f)
|
||||
(define is-actually-aspell? #f)
|
||||
|
||||
(define (fire-up-aspell)
|
||||
(unless already-attempted-aspell?
|
||||
|
|
@ -106,8 +105,6 @@
|
|||
(define line (with-handlers ((exn:fail? exn-message))
|
||||
(read-line (list-ref aspell-proc 0))))
|
||||
(asp-log (format "framework: started speller: ~a" line))
|
||||
(when (regexp-match? #rx"[Aa]spell" line)
|
||||
(set! is-actually-aspell? #t))
|
||||
|
||||
(when (and (string? line)
|
||||
(regexp-match #rx"[Aa]spell" line))
|
||||
|
|
@ -132,12 +129,7 @@
|
|||
(close-output-port (list-ref aspell-proc 1))
|
||||
(close-input-port (list-ref aspell-proc 3))
|
||||
(proc 'kill)
|
||||
(set! aspell-proc #f)
|
||||
(set! is-actually-aspell? #f))
|
||||
|
||||
(define (is-ascii? l)
|
||||
(for/and ([s (in-string l)])
|
||||
(<= (char->integer s) 127)))
|
||||
(set! aspell-proc #f))
|
||||
|
||||
(let loop ()
|
||||
(sync
|
||||
|
|
@ -155,9 +147,7 @@
|
|||
(sync (channel-put-evt resp-chan resp)
|
||||
nack-evt))
|
||||
(cond
|
||||
[(and aspell-proc
|
||||
(or is-actually-aspell?
|
||||
(is-ascii? line)))
|
||||
[aspell-proc
|
||||
(define stdout (list-ref aspell-proc 0))
|
||||
(define stdin (list-ref aspell-proc 1))
|
||||
|
||||
|
|
|
|||
|
|
@ -1118,29 +1118,6 @@
|
|||
|
||||
[define anchor-last-state? #f]
|
||||
[define overwrite-last-state? #f]
|
||||
|
||||
(define/private (update-ascii-art-enlarge-msg)
|
||||
(define ascii-art-enlarge-mode?
|
||||
(let ([e (get-info-editor)])
|
||||
(and (is-a? e text:ascii-art-enlarge-boxes<%>)
|
||||
(send e get-ascii-art-enlarge))))
|
||||
(unless (eq? (and (member ascii-art-enlarge-mode-msg (send uncommon-parent get-children)) #t)
|
||||
ascii-art-enlarge-mode?)
|
||||
(if ascii-art-enlarge-mode?
|
||||
(add-uncommon-child ascii-art-enlarge-mode-msg)
|
||||
(remove-uncommon-child ascii-art-enlarge-mode-msg))))
|
||||
|
||||
;; this callback is kind of a hack. we know that when the set-ascii-art-enlarge
|
||||
;; method of text:ascii-art-enlarge<%> is called that it changes the preferences
|
||||
;; value so we will get called back here; it would be better if we could just
|
||||
;; have the callback happen directly by overriding that method, but that causes
|
||||
;; backwards incompatibility problems.
|
||||
(define callback (λ (p v)
|
||||
(queue-callback
|
||||
(λ () (update-ascii-art-enlarge-msg))
|
||||
#f)))
|
||||
(preferences:add-callback 'framework:ascii-art-enlarge callback #t)
|
||||
|
||||
|
||||
(field (macro-recording? #f))
|
||||
(define/private (update-macro-recording-icon)
|
||||
|
|
@ -1216,7 +1193,6 @@
|
|||
(define/override (update-info)
|
||||
(super update-info)
|
||||
(update-macro-recording-icon)
|
||||
(update-ascii-art-enlarge-msg)
|
||||
(overwrite-status-changed)
|
||||
(anchor-status-changed)
|
||||
(editor-position-changed)
|
||||
|
|
@ -1257,11 +1233,6 @@
|
|||
|
||||
(send (get-info-panel) change-children
|
||||
(λ (l) (cons uncommon-parent (remq uncommon-parent l))))
|
||||
|
||||
(define ascii-art-enlarge-mode-msg (new message%
|
||||
[parent uncommon-parent]
|
||||
[label "╠╬╣"]
|
||||
[auto-resize #t]))
|
||||
(define anchor-message
|
||||
(new message%
|
||||
[font small-control-font]
|
||||
|
|
@ -1283,7 +1254,6 @@
|
|||
(define/private (add-uncommon-child c)
|
||||
(define (child->num c)
|
||||
(cond
|
||||
[(eq? c ascii-art-enlarge-mode-msg) -1]
|
||||
[(eq? c anchor-message) 0]
|
||||
[(eq? c overwrite-message) 1]
|
||||
[(eq? c macro-recording-message) 2]))
|
||||
|
|
@ -2083,13 +2053,10 @@
|
|||
(let* ([string (get-text)]
|
||||
[top-searching-edit (get-searching-text)])
|
||||
(when top-searching-edit
|
||||
(let ([searching-edit
|
||||
(let loop ([txt top-searching-edit])
|
||||
(define focus-snip (send txt get-focus-snip))
|
||||
(cond
|
||||
[(and focus-snip (is-a? focus-snip editor-snip%))
|
||||
(loop (send focus-snip get-editor))]
|
||||
[else txt]))]
|
||||
(let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
|
||||
(if (and focus-snip (is-a? focus-snip editor-snip%))
|
||||
(send focus-snip get-editor)
|
||||
top-searching-edit))]
|
||||
|
||||
[not-found
|
||||
(λ (found-edit skip-beep?)
|
||||
|
|
|
|||
|
|
@ -180,12 +180,7 @@
|
|||
`(@defmethod[(,(between->name x) [menu (is-a?/c menu-item%)]) void?]{
|
||||
This method is called between the addition of the
|
||||
@tt[,(format "~a" (between-before x))] and the @tt[,(format "~a" (between-after x))] menu-item.
|
||||
Override it to add additional menu items at that point.
|
||||
|
||||
@unquote[(if (equal? (between-procedure x) 'separator)
|
||||
`@list{Defaults to creating a @racket[separator-menu-item%].}
|
||||
"")]
|
||||
})]
|
||||
Override it to add additional menu items at that point. })]
|
||||
[(an-item? x)
|
||||
`(@defmethod[(,(an-item->get-item-name x)) (or/c false/c (is-a?/c menu-item%))]{
|
||||
This method returns the @racket[menu-item%] object corresponding
|
||||
|
|
|
|||
|
|
@ -173,23 +173,10 @@
|
|||
|
||||
;; install-recent-items : (is-a?/c menu%) -> void?
|
||||
(define (install-recent-items menu)
|
||||
;; sometimes, we get here via an on-demand callback
|
||||
;; and we run out of time during the callback and
|
||||
;; things go awry with the menu. So, to hack around
|
||||
;; that problem, lets try to do it twice; once here
|
||||
;; when we notice that things are wrong, and then once
|
||||
;; in a later event callback, when we know we won't run
|
||||
;; afoul of any time limits.
|
||||
(do-install-recent-items menu)
|
||||
(queue-callback (λ () (do-install-recent-items menu)) #f)
|
||||
(void))
|
||||
|
||||
(define (do-install-recent-items menu)
|
||||
(define recently-opened-files
|
||||
(preferences:get
|
||||
'framework:recently-opened-files/pos))
|
||||
|
||||
(unless (menu-items-still-same? recently-opened-files menu)
|
||||
(define (update-menu-with-new-stuff)
|
||||
(for ([item (send menu get-items)]) (send item delete))
|
||||
|
||||
(for ([recent-list-item recently-opened-files])
|
||||
|
|
@ -201,7 +188,20 @@
|
|||
(new menu-item%
|
||||
[parent menu]
|
||||
[label (string-constant show-recent-items-window-menu-item)]
|
||||
[callback (λ (x y) (show-recent-items-window))])))
|
||||
[callback (λ (x y) (show-recent-items-window))]))
|
||||
(unless (menu-items-still-same? recently-opened-files menu)
|
||||
|
||||
;; sometimes, we get here via an on-demand callback
|
||||
;; and we run out of time during the callback and
|
||||
;; things go awry with the menu. So, to hack around
|
||||
;; that problem, lets try to do it twice; once here
|
||||
;; when we notice that things are wrong, and then once
|
||||
;; later, when we know we won't run afoul of any time
|
||||
;; limits.
|
||||
|
||||
(queue-callback (λ () (update-menu-with-new-stuff)) #f)
|
||||
(update-menu-with-new-stuff))
|
||||
(void))
|
||||
|
||||
(define (recent-list-item->menu-label recent-list-item)
|
||||
(let ([filename (car recent-list-item)])
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@
|
|||
frame:basic<%>
|
||||
frame:standard-menus<%>
|
||||
frame:info<%>
|
||||
frame:text-info<%>
|
||||
text:ascii-art-enlarge-boxes<%>)
|
||||
frame:text-info<%>)
|
||||
|
||||
(define editor:basic<%>
|
||||
(interface (editor<%>)
|
||||
|
|
@ -33,12 +32,6 @@
|
|||
(interface (editor:basic<%>)
|
||||
get-keymaps))
|
||||
|
||||
|
||||
(define text:ascii-art-enlarge-boxes<%>
|
||||
(interface ()
|
||||
set-ascii-art-enlarge
|
||||
get-ascii-art-enlarge))
|
||||
|
||||
(define text:basic<%>
|
||||
(interface (editor:basic<%> (class->interface text%))
|
||||
highlight-range
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@
|
|||
"interfaces.rkt"
|
||||
"../preferences.rkt"
|
||||
"gen-standard-menus.rkt"
|
||||
"unicode-ascii-art.rkt"
|
||||
(only-in srfi/13 string-prefix? string-prefix-length)
|
||||
2d/dir-chars
|
||||
racket/list)
|
||||
|
|
@ -709,17 +708,6 @@
|
|||
(define start (send txt get-start-position))
|
||||
(when (= start (send txt get-end-position))
|
||||
(widen-unicode-ascii-art-box txt start)))]
|
||||
|
||||
[heighten-unicode-ascii-art-box
|
||||
(λ (txt evt)
|
||||
(define start (send txt get-start-position))
|
||||
(when (= start (send txt get-end-position))
|
||||
(heighten-unicode-ascii-art-box txt start)))]
|
||||
|
||||
[toggle-unicode-ascii-art-enlarge-mode
|
||||
(λ (txt evt)
|
||||
(when (is-a? txt text:ascii-art-enlarge-boxes<%>)
|
||||
(send txt set-ascii-art-enlarge (not (send txt get-ascii-art-enlarge)))))]
|
||||
|
||||
[center-in-unicode-ascii-art-box
|
||||
(λ (txt evt)
|
||||
|
|
@ -752,8 +740,6 @@
|
|||
|
||||
(add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box)
|
||||
(add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box)
|
||||
(add "heighten-unicode-ascii-art-box" heighten-unicode-ascii-art-box)
|
||||
(add "toggle-unicode-ascii-art-enlarge-mode" toggle-unicode-ascii-art-enlarge-mode)
|
||||
(add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box)
|
||||
(add "shift-focus" (shift-focus values))
|
||||
(add "shift-focus-backwards" (shift-focus reverse))
|
||||
|
|
@ -850,9 +836,7 @@
|
|||
|
||||
(map "c:x;r;a" "normalize-unicode-ascii-art-box")
|
||||
(map "c:x;r;w" "widen-unicode-ascii-art-box")
|
||||
(map "c:x;r;v" "highten-unicode-ascii-art-box")
|
||||
(map "c:x;r;c" "center-in-unicode-ascii-art-box")
|
||||
(map "c:x;r;o" "toggle-unicode-ascii-art-enlarge-mode")
|
||||
|
||||
(map "~m:c:\\" "TeX compress")
|
||||
(map "~c:m:\\" "TeX compress")
|
||||
|
|
@ -1043,6 +1027,166 @@
|
|||
(f click-pos eol start-pos click-pos)
|
||||
(f click-pos eol click-pos end-pos))))
|
||||
|
||||
|
||||
|
||||
(define (widen-unicode-ascii-art-box t orig-pos)
|
||||
(define start-pos (scan-for-start-pos t orig-pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(define-values (start-x start-y) (pos->xy t orig-pos))
|
||||
(define min-y #f)
|
||||
(define max-y #f)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(when (= x start-x)
|
||||
(unless min-y
|
||||
(set! min-y y)
|
||||
(set! max-y y))
|
||||
(set! min-y (min y min-y))
|
||||
(set! max-y (max y max-y)))))
|
||||
(define to-adjust 0)
|
||||
(for ([y (in-range max-y (- min-y 1) -1)])
|
||||
(define-values (pos char) (xy->pos t start-x y))
|
||||
(when (< pos start-pos)
|
||||
(set! to-adjust (+ to-adjust 1)))
|
||||
(send t insert
|
||||
(cond
|
||||
[(member char lt-chars) #\═]
|
||||
[else #\space])
|
||||
pos pos))
|
||||
(send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1))
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (normalize-unicode-ascii-art-box t pos)
|
||||
(define start-pos (scan-for-start-pos t pos))
|
||||
(when start-pos
|
||||
(send t begin-edit-sequence)
|
||||
(trace-unicode-ascii-art-box
|
||||
t start-pos #f
|
||||
(λ (pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(cond
|
||||
[(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")]
|
||||
[(and i-dn? i-lt? i-rt?) (set-c t pos "╦")]
|
||||
[(and i-up? i-lt? i-rt?) (set-c t pos "╩")]
|
||||
[(and i-up? i-dn? i-rt?) (set-c t pos "╠")]
|
||||
[(and i-up? i-dn? i-lt?) (set-c t pos "╣")]
|
||||
[(and i-up? i-lt?) (set-c t pos "╝")]
|
||||
[(and i-up? i-rt?) (set-c t pos "╚")]
|
||||
[(and i-dn? i-lt?) (set-c t pos "╗")]
|
||||
[(and i-dn? i-rt?) (set-c t pos "╔")]
|
||||
[(or i-up? i-dn?) (set-c t pos "║")]
|
||||
[else (set-c t pos "═")])))
|
||||
(send t end-edit-sequence)))
|
||||
|
||||
(define (center-in-unicode-ascii-art-box txt insertion-pos)
|
||||
(define (find-something start-pos inc char-p?)
|
||||
(define-values (x y) (pos->xy txt start-pos))
|
||||
(let loop ([pos start-pos])
|
||||
(cond
|
||||
[(char-p? (send txt get-character pos))
|
||||
pos]
|
||||
[else
|
||||
(define new-pos (inc pos))
|
||||
(cond
|
||||
[(<= 0 new-pos (send txt last-position))
|
||||
(define-values (x2 y2) (pos->xy txt new-pos))
|
||||
(cond
|
||||
[(= y2 y)
|
||||
(loop new-pos)]
|
||||
[else #f])]
|
||||
[else #f])])))
|
||||
|
||||
(define (adjust-space before-space after-space pos)
|
||||
(cond
|
||||
[(< before-space after-space)
|
||||
(send txt insert (make-string (- after-space before-space) #\space) pos pos)]
|
||||
[(> before-space after-space)
|
||||
(send txt delete pos (+ pos (- before-space after-space)))]))
|
||||
|
||||
(define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║))))
|
||||
(define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║))))
|
||||
(when (and left-bar right-bar (< left-bar right-bar))
|
||||
(define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x)))))
|
||||
(define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x)))))
|
||||
(when (and left-space-edge right-space-edge)
|
||||
(define before-left-space-count (- left-space-edge left-bar 1))
|
||||
(define before-right-space-count (- right-bar right-space-edge 1))
|
||||
(define tot-space (+ before-left-space-count before-right-space-count))
|
||||
(define after-left-space-count (floor (/ tot-space 2)))
|
||||
(define after-right-space-count (ceiling (/ tot-space 2)))
|
||||
(send txt begin-edit-sequence)
|
||||
(adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1))
|
||||
(adjust-space before-left-space-count after-left-space-count (+ left-bar 1))
|
||||
(send txt end-edit-sequence))))
|
||||
|
||||
(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f)
|
||||
(define visited (make-hash))
|
||||
(let loop ([pos start-pos])
|
||||
(unless (hash-ref visited pos #f)
|
||||
(hash-set! visited pos #t)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(define c (send t get-character pos))
|
||||
(define-values (up upc) (xy->pos t x (- y 1)))
|
||||
(define-values (dn dnc) (xy->pos t x (+ y 1)))
|
||||
(define-values (lt ltc) (xy->pos t (- x 1) y))
|
||||
(define-values (rt rtc) (xy->pos t (+ x 1) y))
|
||||
(define (interesting-dir? dir-c dir-chars)
|
||||
(or (and (not only-double-barred-chars?)
|
||||
(member dir-c adjustable-chars)
|
||||
(member c dir-chars))
|
||||
(and (member dir-c double-barred-chars)
|
||||
(member c double-barred-chars))))
|
||||
(define i-up? (interesting-dir? upc up-chars))
|
||||
(define i-dn? (interesting-dir? dnc dn-chars))
|
||||
(define i-lt? (interesting-dir? ltc lt-chars))
|
||||
(define i-rt? (interesting-dir? rtc rt-chars))
|
||||
(f pos x y i-up? i-dn? i-lt? i-rt?)
|
||||
(when i-up? (loop up))
|
||||
(when i-dn? (loop dn))
|
||||
(when i-lt? (loop lt))
|
||||
(when i-rt? (loop rt)))))
|
||||
|
||||
(define (scan-for-start-pos t pos)
|
||||
(define-values (x y) (pos->xy t pos))
|
||||
(findf
|
||||
(λ (p) (adj? t p))
|
||||
(for*/list ([xadj '(0 -1)]
|
||||
[yadj '(0 -1 1)])
|
||||
(define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj)))
|
||||
d)))
|
||||
|
||||
(define (adj? t pos)
|
||||
(and pos
|
||||
(member (send t get-character pos)
|
||||
adjustable-chars)))
|
||||
|
||||
(define (set-c t pos s)
|
||||
(unless (equal? (string-ref s 0) (send t get-character pos))
|
||||
(send t delete pos (+ pos 1))
|
||||
(send t insert s pos pos)))
|
||||
|
||||
(define (pos->xy text pos)
|
||||
(define para (send text position-paragraph pos))
|
||||
(define start (send text paragraph-start-position para))
|
||||
(values (- pos start) para))
|
||||
|
||||
(define (xy->pos text x y)
|
||||
(cond
|
||||
[(and (<= 0 x) (<= 0 y (send text last-paragraph)))
|
||||
(define para-start (send text paragraph-start-position y))
|
||||
(define para-end (send text paragraph-end-position y))
|
||||
(define pos (+ para-start x))
|
||||
(define res-pos
|
||||
(and (< pos para-end)
|
||||
;; the newline at the end of the
|
||||
;; line is not on the line, so use this guard
|
||||
pos))
|
||||
(if res-pos
|
||||
(values res-pos (send text get-character res-pos))
|
||||
(values #f #f))]
|
||||
[else (values #f #f)]))
|
||||
|
||||
(define/contract (run-some-keystrokes before key-evts)
|
||||
(-> (list/c string? exact-nonnegative-integer? exact-nonnegative-integer?)
|
||||
(listof (is-a?/c key-event%))
|
||||
|
|
@ -1060,7 +1204,182 @@
|
|||
(send t get-end-position)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require rackunit
|
||||
racket/gui/base)
|
||||
(define sa string-append)
|
||||
|
||||
(define (first-value-xy->pos a b c)
|
||||
(define-values (d e) (xy->pos a b c))
|
||||
d)
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi\n"))
|
||||
(check-equal? (first-value-xy->pos t 0 0) 0)
|
||||
(check-equal? (first-value-xy->pos t 1 0) 1)
|
||||
(check-equal? (first-value-xy->pos t 0 1) 4)
|
||||
(check-equal? (first-value-xy->pos t 3 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 3) #f)
|
||||
(check-equal? (first-value-xy->pos t 1 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 1) #f)
|
||||
(check-equal? (first-value-xy->pos t 0 2) 6)
|
||||
(check-equal? (first-value-xy->pos t 1 2) 7)
|
||||
(check-equal? (first-value-xy->pos t 2 -1) #f)
|
||||
(check-equal? (first-value-xy->pos t -1 0) #f)
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (sa "abc\n"
|
||||
"d\n"
|
||||
"ghi"))
|
||||
(check-equal? (first-value-xy->pos t 2 2) 8)
|
||||
(check-equal? (first-value-xy->pos t 2 3) #f))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+\n"
|
||||
"| |\n"
|
||||
"+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+=+\n"
|
||||
"| |\n"
|
||||
"+=+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╗\n"
|
||||
"║ ║\n"
|
||||
"╚═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append "+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"
|
||||
"| | |\n"
|
||||
"+-+-+\n"))
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n"))
|
||||
|
||||
(normalize-unicode-ascii-art-box t 0)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔═══╗\n"
|
||||
"║ - ║\n"
|
||||
"╚═══╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 1 1)
|
||||
(widen-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-start-position) 2)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-start-position) 10)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert (string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"))
|
||||
(send t set-position 8 8)
|
||||
(widen-unicode-ascii-art-box t 8)
|
||||
(check-equal? (send t get-text)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n")))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║x ║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║ x║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║ x ║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║║\n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert "║abcde \n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
"║abcde \n"))
|
||||
|
||||
(let ([t (new text%)])
|
||||
(send t insert " abcde║\n")
|
||||
(center-in-unicode-ascii-art-box t 1)
|
||||
(check-equal? (send t get-text)
|
||||
" abcde║\n"))
|
||||
|
||||
(check-equal? (run-some-keystrokes '("abc" 0 0)
|
||||
(list (new key-event% [key-code 'escape])
|
||||
(new key-event% [key-code #\c])))
|
||||
|
|
|
|||
|
|
@ -148,38 +148,7 @@
|
|||
(hash-set! function-table (string->symbol keyname) fname))
|
||||
|
||||
(define/public (get-map-function-table)
|
||||
(define table-possibly-with-prefixes (get-map-function-table/ht (make-hasheq)))
|
||||
|
||||
(define trie (make-hash))
|
||||
(define (add-to-trie loks name)
|
||||
(let loop ([trie trie]
|
||||
[loks loks])
|
||||
(cond
|
||||
[(null? (cdr loks))
|
||||
(hash-set! trie (car loks) name)]
|
||||
[else
|
||||
(define sub (hash-ref trie (car loks)
|
||||
(λ ()
|
||||
(define h (make-hash))
|
||||
(hash-set! trie (car loks) h)
|
||||
h)))
|
||||
(loop sub (cdr loks))])))
|
||||
|
||||
(for ([(canonicalized-symbol keyname) (in-hash table-possibly-with-prefixes)])
|
||||
(define keys (regexp-split #rx";" (symbol->string canonicalized-symbol)))
|
||||
(add-to-trie keys keyname))
|
||||
|
||||
(define table-without-prefixes (make-hash))
|
||||
(let loop ([trie trie]
|
||||
[prefix '()])
|
||||
(cond
|
||||
[(string? trie)
|
||||
(define keystring (string->symbol (join-strings ";" (reverse prefix))))
|
||||
(hash-set! table-without-prefixes keystring trie)]
|
||||
[else (for ([(key sub-trie) (in-hash trie)])
|
||||
(loop sub-trie (cons key prefix)))]))
|
||||
|
||||
table-without-prefixes)
|
||||
(get-map-function-table/ht (make-hasheq)))
|
||||
|
||||
(define/public (get-map-function-table/ht table)
|
||||
(for ([(keyname fname) (in-hash function-table)])
|
||||
|
|
|
|||
|
|
@ -25,8 +25,6 @@
|
|||
|
||||
(application-preferences-handler (λ () (preferences:show-dialog)))
|
||||
|
||||
(preferences:set-default 'framework:ascii-art-enlarge #f boolean?)
|
||||
|
||||
(preferences:set-default 'framework:color-scheme 'classic symbol?)
|
||||
|
||||
(preferences:set-default 'framework:column-guide-width
|
||||
|
|
|
|||
|
|
@ -504,6 +504,12 @@
|
|||
[else
|
||||
(+ i 1)])))
|
||||
|
||||
(public tabify-all insert-return calc-last-para
|
||||
box-comment-out-selection comment-out-selection uncomment-selection
|
||||
flash-forward-sexp
|
||||
flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
|
||||
remove-parens-forward)
|
||||
|
||||
(define/public (get-limit pos) 0)
|
||||
|
||||
(define/public (balance-parens key-event [smart-skip #f])
|
||||
|
|
@ -558,15 +564,11 @@
|
|||
tab-char?))
|
||||
(define/pubment (compute-amount-to-indent pos)
|
||||
(inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos))
|
||||
(define/public-final (compute-racket-amount-to-indent pos [_get-head-sexp-type (λ (x) #f)])
|
||||
(define/public-final (compute-racket-amount-to-indent pos)
|
||||
(cond
|
||||
[(is-stopped?) #f]
|
||||
[else
|
||||
(define get-head-sexp-type
|
||||
(let ([tabify-prefs (preferences:get 'framework:tabify)])
|
||||
(λ (text)
|
||||
(or (_get-head-sexp-type text)
|
||||
(get-head-sexp-type-from-prefs text tabify-prefs)))))
|
||||
(define tabify-prefs (preferences:get 'framework:tabify))
|
||||
(define last-pos (last-position))
|
||||
(define para (position-paragraph pos))
|
||||
(define is-tabbable?
|
||||
|
|
@ -625,7 +627,8 @@
|
|||
(let ([text (get-text contains id-end)])
|
||||
(cond
|
||||
[(member (classify-position contains) '(keyword symbol))
|
||||
(get-head-sexp-type text)]
|
||||
(or (get-keyword-type text tabify-prefs)
|
||||
'other)]
|
||||
[else
|
||||
'other]))))
|
||||
(define (procedure-indent)
|
||||
|
|
@ -691,24 +694,18 @@
|
|||
;; So far, the S-exp containing "pos" was all on
|
||||
;; one line (possibly not counting the opening paren),
|
||||
;; so indent to follow the first S-exp's end
|
||||
;; unless
|
||||
;; - there are just two sexps earlier and the second is an ellipsis.
|
||||
;; in that case, we just ignore the ellipsis or
|
||||
;; - the sexp we are indenting is a bunch of hypens;
|
||||
;; in that case, we match the opening paren
|
||||
;; unless there are just two sexps and the second is an ellipsis.
|
||||
;; in that case, we just ignore the ellipsis
|
||||
(define id-end (get-forward-sexp contains))
|
||||
(define name-length
|
||||
(if id-end
|
||||
(- id-end contains)
|
||||
0))
|
||||
(cond
|
||||
[(or (first-sexp-is-keyword? contains)
|
||||
(sexp-is-all-hyphens? contains))
|
||||
[(first-sexp-is-keyword? contains)
|
||||
(visual-offset contains)]
|
||||
[(second-sexp-is-ellipsis? contains)
|
||||
(visual-offset contains)]
|
||||
[(sexp-is-all-hyphens? pos)
|
||||
(visual-offset contains)]
|
||||
[(not (find-up-sexp pos))
|
||||
(visual-offset contains)]
|
||||
[else
|
||||
|
|
@ -727,21 +724,6 @@
|
|||
(loop next-to-last next-to-last-para)
|
||||
(visual-offset last))))]))
|
||||
amt-to-indent]))
|
||||
|
||||
;; returns #t if `pos` is in a symbol (or keyword) that consists entirely
|
||||
;; of hyphens and has at least three hyphens; returns #f otherwise
|
||||
(define/private (sexp-is-all-hyphens? pos)
|
||||
(define fst-end (get-forward-sexp pos))
|
||||
(and fst-end
|
||||
(let ([fst-start (get-backward-sexp fst-end)])
|
||||
(and fst-start
|
||||
(memq (classify-position fst-start) '(symbol keyword))
|
||||
(>= (- fst-end fst-start) 3)
|
||||
(let loop ([i fst-start])
|
||||
(cond
|
||||
[(< i fst-end)
|
||||
(and (equal? #\- (get-character i)) (loop (+ i 1)))]
|
||||
[else #t]))))))
|
||||
|
||||
;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else.
|
||||
;; otherwise, returns #f
|
||||
|
|
@ -771,7 +753,6 @@
|
|||
(unless (is-stopped?)
|
||||
(define first-para (position-paragraph start-pos))
|
||||
(define end-para (position-paragraph end-pos))
|
||||
(define tabifying-multiple-paras? (not (= first-para end-para)))
|
||||
(with-handlers ([exn:break?
|
||||
(λ (x) #t)])
|
||||
(dynamic-wind
|
||||
|
|
@ -782,14 +763,7 @@
|
|||
(λ ()
|
||||
(let loop ([para first-para])
|
||||
(when (<= para end-para)
|
||||
(define start (paragraph-start-position para))
|
||||
(define end (paragraph-end-position para))
|
||||
(define skip-this-line?
|
||||
(and tabifying-multiple-paras?
|
||||
(for/and ([i (in-range start (+ end 1))])
|
||||
(char-whitespace? (get-character i)))))
|
||||
(unless skip-this-line?
|
||||
(tabify start))
|
||||
(tabify (paragraph-start-position para))
|
||||
(parameterize-break #t (void))
|
||||
(loop (add1 para))))
|
||||
(when (and (>= (position-paragraph start-pos) end-para)
|
||||
|
|
@ -807,8 +781,8 @@
|
|||
(when (< first-para end-para)
|
||||
(end-busy-cursor)))))))
|
||||
|
||||
(define/public (tabify-all) (tabify-selection 0 (last-position)))
|
||||
(define/public (insert-return)
|
||||
(define (tabify-all) (tabify-selection 0 (last-position)))
|
||||
(define (insert-return)
|
||||
(begin-edit-sequence #t #f)
|
||||
(define end-of-whitespace (get-start-position))
|
||||
(define start-cutoff
|
||||
|
|
@ -832,7 +806,7 @@
|
|||
new-pos))))
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/public (calc-last-para last-pos)
|
||||
(define (calc-last-para last-pos)
|
||||
(let ([last-para (position-paragraph last-pos #t)])
|
||||
(if (and (> last-pos 0)
|
||||
(> last-para 0))
|
||||
|
|
@ -843,53 +817,55 @@
|
|||
last-para)))
|
||||
last-para)))
|
||||
|
||||
(define/public (comment-out-selection [start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(begin-edit-sequence)
|
||||
(let ([first-pos-is-first-para-pos?
|
||||
(= (paragraph-start-position (position-paragraph start-pos))
|
||||
start-pos)])
|
||||
(let* ([first-para (position-paragraph start-pos)]
|
||||
[last-para (calc-last-para end-pos)])
|
||||
(let para-loop ([curr-para first-para])
|
||||
(when (<= curr-para last-para)
|
||||
(let ([first-on-para (paragraph-start-position curr-para)])
|
||||
(insert #\; first-on-para)
|
||||
(para-loop (add1 curr-para))))))
|
||||
(when first-pos-is-first-para-pos?
|
||||
(set-position
|
||||
(paragraph-start-position (position-paragraph (get-start-position)))
|
||||
(get-end-position))))
|
||||
(end-edit-sequence)
|
||||
#t)
|
||||
(define comment-out-selection
|
||||
(lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(begin-edit-sequence)
|
||||
(let ([first-pos-is-first-para-pos?
|
||||
(= (paragraph-start-position (position-paragraph start-pos))
|
||||
start-pos)])
|
||||
(let* ([first-para (position-paragraph start-pos)]
|
||||
[last-para (calc-last-para end-pos)])
|
||||
(let para-loop ([curr-para first-para])
|
||||
(when (<= curr-para last-para)
|
||||
(let ([first-on-para (paragraph-start-position curr-para)])
|
||||
(insert #\; first-on-para)
|
||||
(para-loop (add1 curr-para))))))
|
||||
(when first-pos-is-first-para-pos?
|
||||
(set-position
|
||||
(paragraph-start-position (position-paragraph (get-start-position)))
|
||||
(get-end-position))))
|
||||
(end-edit-sequence)
|
||||
#t))
|
||||
|
||||
(define/public (box-comment-out-selection [_start-pos 'start]
|
||||
[_end-pos 'end])
|
||||
(let ([start-pos (if (eq? _start-pos 'start)
|
||||
(get-start-position)
|
||||
_start-pos)]
|
||||
[end-pos (if (eq? _end-pos 'end)
|
||||
(get-end-position)
|
||||
_end-pos)])
|
||||
(begin-edit-sequence)
|
||||
(split-snip start-pos)
|
||||
(split-snip end-pos)
|
||||
(let* ([cb (instantiate comment-box:snip% ())]
|
||||
[text (send cb get-editor)])
|
||||
(let loop ([snip (find-snip start-pos 'after-or-none)])
|
||||
(cond
|
||||
[(not snip) (void)]
|
||||
[((get-snip-position snip) . >= . end-pos) (void)]
|
||||
[else
|
||||
(send text insert (send snip copy)
|
||||
(send text last-position)
|
||||
(send text last-position))
|
||||
(loop (send snip next))]))
|
||||
(delete start-pos end-pos)
|
||||
(insert cb start-pos)
|
||||
(set-position start-pos start-pos))
|
||||
(end-edit-sequence)
|
||||
#t))
|
||||
(define box-comment-out-selection
|
||||
(lambda ([_start-pos 'start]
|
||||
[_end-pos 'end])
|
||||
(let ([start-pos (if (eq? _start-pos 'start)
|
||||
(get-start-position)
|
||||
_start-pos)]
|
||||
[end-pos (if (eq? _end-pos 'end)
|
||||
(get-end-position)
|
||||
_end-pos)])
|
||||
(begin-edit-sequence)
|
||||
(split-snip start-pos)
|
||||
(split-snip end-pos)
|
||||
(let* ([cb (instantiate comment-box:snip% ())]
|
||||
[text (send cb get-editor)])
|
||||
(let loop ([snip (find-snip start-pos 'after-or-none)])
|
||||
(cond
|
||||
[(not snip) (void)]
|
||||
[((get-snip-position snip) . >= . end-pos) (void)]
|
||||
[else
|
||||
(send text insert (send snip copy)
|
||||
(send text last-position)
|
||||
(send text last-position))
|
||||
(loop (send snip next))]))
|
||||
(delete start-pos end-pos)
|
||||
(insert cb start-pos)
|
||||
(set-position start-pos start-pos))
|
||||
(end-edit-sequence)
|
||||
#t)))
|
||||
|
||||
;; uncomment-box/selection : -> void
|
||||
;; uncomments a comment box, if the focus is inside one.
|
||||
|
|
@ -909,43 +885,44 @@
|
|||
(end-edit-sequence)
|
||||
#t)
|
||||
|
||||
(define/public (uncomment-selection [start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(let ([snip-before (find-snip start-pos 'before-or-none)]
|
||||
[snip-after (find-snip start-pos 'after-or-none)])
|
||||
(define uncomment-selection
|
||||
(lambda ([start-pos (get-start-position)]
|
||||
[end-pos (get-end-position)])
|
||||
(let ([snip-before (find-snip start-pos 'before-or-none)]
|
||||
[snip-after (find-snip start-pos 'after-or-none)])
|
||||
|
||||
(begin-edit-sequence)
|
||||
(cond
|
||||
[(and (= start-pos end-pos)
|
||||
snip-before
|
||||
(is-a? snip-before comment-box:snip%))
|
||||
(extract-contents start-pos snip-before)]
|
||||
[(and (= start-pos end-pos)
|
||||
snip-after
|
||||
(is-a? snip-after comment-box:snip%))
|
||||
(extract-contents start-pos snip-after)]
|
||||
[(and (= (+ start-pos 1) end-pos)
|
||||
snip-after
|
||||
(is-a? snip-after comment-box:snip%))
|
||||
(extract-contents start-pos snip-after)]
|
||||
[else
|
||||
(let* ([last-pos (last-position)]
|
||||
[first-para (position-paragraph start-pos)]
|
||||
[last-para (calc-last-para end-pos)])
|
||||
(let para-loop ([curr-para first-para])
|
||||
(when (<= curr-para last-para)
|
||||
(let ([first-on-para
|
||||
(skip-whitespace (paragraph-start-position curr-para)
|
||||
'forward
|
||||
#f)])
|
||||
(split-snip first-on-para)
|
||||
(when (and (< first-on-para last-pos)
|
||||
(char=? #\; (get-character first-on-para))
|
||||
(is-a? (find-snip first-on-para 'after-or-none) string-snip%))
|
||||
(delete first-on-para (+ first-on-para 1)))
|
||||
(para-loop (add1 curr-para))))))])
|
||||
(end-edit-sequence))
|
||||
#t)
|
||||
(begin-edit-sequence)
|
||||
(cond
|
||||
[(and (= start-pos end-pos)
|
||||
snip-before
|
||||
(is-a? snip-before comment-box:snip%))
|
||||
(extract-contents start-pos snip-before)]
|
||||
[(and (= start-pos end-pos)
|
||||
snip-after
|
||||
(is-a? snip-after comment-box:snip%))
|
||||
(extract-contents start-pos snip-after)]
|
||||
[(and (= (+ start-pos 1) end-pos)
|
||||
snip-after
|
||||
(is-a? snip-after comment-box:snip%))
|
||||
(extract-contents start-pos snip-after)]
|
||||
[else
|
||||
(let* ([last-pos (last-position)]
|
||||
[first-para (position-paragraph start-pos)]
|
||||
[last-para (calc-last-para end-pos)])
|
||||
(let para-loop ([curr-para first-para])
|
||||
(when (<= curr-para last-para)
|
||||
(let ([first-on-para
|
||||
(skip-whitespace (paragraph-start-position curr-para)
|
||||
'forward
|
||||
#f)])
|
||||
(split-snip first-on-para)
|
||||
(when (and (< first-on-para last-pos)
|
||||
(char=? #\; (get-character first-on-para))
|
||||
(is-a? (find-snip first-on-para 'after-or-none) string-snip%))
|
||||
(delete first-on-para (+ first-on-para 1)))
|
||||
(para-loop (add1 curr-para))))))])
|
||||
(end-edit-sequence))
|
||||
#t))
|
||||
|
||||
;; extract-contents : number (is-a?/c comment-box:snip%) -> void
|
||||
;; copies the contents of the comment-box-snip out of the snip
|
||||
|
|
@ -1023,12 +1000,13 @@
|
|||
(set-position end-pos)
|
||||
(bell))
|
||||
#t))
|
||||
(define/public (flash-forward-sexp start-pos)
|
||||
(let ([end-pos (get-forward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))
|
||||
[define flash-forward-sexp
|
||||
(λ (start-pos)
|
||||
(let ([end-pos (get-forward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))]
|
||||
(define/public (get-backward-sexp start-pos)
|
||||
(let* ([limit (get-limit start-pos)]
|
||||
[end-pos (backward-match start-pos limit)]
|
||||
|
|
@ -1047,82 +1025,89 @@
|
|||
end-pos)))
|
||||
;; can't go backward at all:
|
||||
#f)))
|
||||
(define/public (flash-backward-sexp start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))
|
||||
(define/public (backward-sexp start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(set-position end-pos)
|
||||
(bell))
|
||||
#t))
|
||||
(define/public (find-up-sexp start-pos)
|
||||
(let* ([limit-pos (get-limit start-pos)]
|
||||
[exp-pos
|
||||
(backward-containing-sexp start-pos limit-pos)])
|
||||
[define flash-backward-sexp
|
||||
(λ (start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(flash-on end-pos (add1 end-pos))
|
||||
(bell))
|
||||
#t))]
|
||||
[define backward-sexp
|
||||
(λ (start-pos)
|
||||
(let ([end-pos (get-backward-sexp start-pos)])
|
||||
(if end-pos
|
||||
(set-position end-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[define find-up-sexp
|
||||
(λ (start-pos)
|
||||
(let* ([limit-pos (get-limit start-pos)]
|
||||
[exp-pos
|
||||
(backward-containing-sexp start-pos limit-pos)])
|
||||
|
||||
(if (and exp-pos (> exp-pos limit-pos))
|
||||
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
|
||||
[paren-pos
|
||||
(λ (paren-pair)
|
||||
(find-string
|
||||
(car paren-pair)
|
||||
'backward
|
||||
in-start-pos
|
||||
limit-pos))])
|
||||
(let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
|
||||
(cond
|
||||
[(null? parens) null]
|
||||
[else
|
||||
(let ([pos (paren-pos (car parens))])
|
||||
(if pos
|
||||
(cons pos (loop (cdr parens)))
|
||||
(loop (cdr parens))))]))])
|
||||
(if (null? poss) ;; all finds failed
|
||||
#f
|
||||
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
|
||||
#f)))
|
||||
(define/public (up-sexp start-pos)
|
||||
(let ([exp-pos (find-up-sexp start-pos)])
|
||||
(if exp-pos
|
||||
(set-position exp-pos)
|
||||
(bell))
|
||||
#t))
|
||||
(define/public (find-down-sexp start-pos)
|
||||
(let loop ([pos start-pos])
|
||||
(let ([next-pos (get-forward-sexp pos)])
|
||||
(if (and next-pos (> next-pos pos))
|
||||
(let ([back-pos
|
||||
(backward-containing-sexp (sub1 next-pos) pos)])
|
||||
(if (and back-pos
|
||||
(> back-pos pos))
|
||||
back-pos
|
||||
(loop next-pos)))
|
||||
#f))))
|
||||
(define/public (down-sexp start-pos)
|
||||
(let ([pos (find-down-sexp start-pos)])
|
||||
(if pos
|
||||
(set-position pos)
|
||||
(bell))
|
||||
#t))
|
||||
(define/public (remove-parens-forward start-pos)
|
||||
(let* ([pos (skip-whitespace start-pos 'forward #f)]
|
||||
[first-char (get-character pos)]
|
||||
[paren? (or (char=? first-char #\()
|
||||
(char=? first-char #\[)
|
||||
(char=? first-char #\{))]
|
||||
[closer (and paren?
|
||||
(get-forward-sexp pos))])
|
||||
(if (and paren? closer)
|
||||
(begin (begin-edit-sequence #t #f)
|
||||
(delete pos (add1 pos))
|
||||
(delete (- closer 2) (- closer 1))
|
||||
(end-edit-sequence))
|
||||
(bell))
|
||||
#t))
|
||||
(if (and exp-pos (> exp-pos limit-pos))
|
||||
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
|
||||
[paren-pos
|
||||
(λ (paren-pair)
|
||||
(find-string
|
||||
(car paren-pair)
|
||||
'backward
|
||||
in-start-pos
|
||||
limit-pos))])
|
||||
(let ([poss (let loop ([parens (racket-paren:get-paren-pairs)])
|
||||
(cond
|
||||
[(null? parens) null]
|
||||
[else
|
||||
(let ([pos (paren-pos (car parens))])
|
||||
(if pos
|
||||
(cons pos (loop (cdr parens)))
|
||||
(loop (cdr parens))))]))])
|
||||
(if (null? poss) ;; all finds failed
|
||||
#f
|
||||
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
|
||||
#f)))]
|
||||
[define up-sexp
|
||||
(λ (start-pos)
|
||||
(let ([exp-pos (find-up-sexp start-pos)])
|
||||
(if exp-pos
|
||||
(set-position exp-pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[define find-down-sexp
|
||||
(λ (start-pos)
|
||||
(let loop ([pos start-pos])
|
||||
(let ([next-pos (get-forward-sexp pos)])
|
||||
(if (and next-pos (> next-pos pos))
|
||||
(let ([back-pos
|
||||
(backward-containing-sexp (sub1 next-pos) pos)])
|
||||
(if (and back-pos
|
||||
(> back-pos pos))
|
||||
back-pos
|
||||
(loop next-pos)))
|
||||
#f))))]
|
||||
[define down-sexp
|
||||
(λ (start-pos)
|
||||
(let ([pos (find-down-sexp start-pos)])
|
||||
(if pos
|
||||
(set-position pos)
|
||||
(bell))
|
||||
#t))]
|
||||
[define remove-parens-forward
|
||||
(λ (start-pos)
|
||||
(let* ([pos (skip-whitespace start-pos 'forward #f)]
|
||||
[first-char (get-character pos)]
|
||||
[paren? (or (char=? first-char #\()
|
||||
(char=? first-char #\[)
|
||||
(char=? first-char #\{))]
|
||||
[closer (and paren?
|
||||
(get-forward-sexp pos))])
|
||||
(if (and paren? closer)
|
||||
(begin (begin-edit-sequence #t #f)
|
||||
(delete pos (add1 pos))
|
||||
(delete (- closer 2) (- closer 1))
|
||||
(end-edit-sequence))
|
||||
(bell))
|
||||
#t))]
|
||||
|
||||
(define/private (select-text f forward?)
|
||||
(define start-pos (get-start-position))
|
||||
|
|
@ -1139,11 +1124,11 @@
|
|||
(extend-position new-pos)
|
||||
(bell))
|
||||
#t)
|
||||
|
||||
(define/public (select-forward-sexp) (select-text (λ (x) (get-forward-sexp x)) #t))
|
||||
(define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f))
|
||||
(define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f))
|
||||
(define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t))
|
||||
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp)
|
||||
[define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
|
||||
[define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
|
||||
[define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
|
||||
[define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
|
||||
|
||||
(define/public (introduce-let-ans pos)
|
||||
(dynamic-wind
|
||||
|
|
@ -1289,9 +1274,10 @@
|
|||
(for-each (λ (s) (insert s start-1)) snips-2/rev)
|
||||
(set-position end-2)
|
||||
(end-edit-sequence)))))))))))
|
||||
(define tab-size 8)
|
||||
(define/public (get-tab-size) tab-size)
|
||||
(define/public (set-tab-size s) (set! tab-size s))
|
||||
[define tab-size 8]
|
||||
(public get-tab-size set-tab-size)
|
||||
[define get-tab-size (λ () tab-size)]
|
||||
[define set-tab-size (λ (s) (set! tab-size s))]
|
||||
|
||||
(define/override (get-start-of-line pos)
|
||||
(define para (position-paragraph pos))
|
||||
|
|
@ -1359,7 +1345,7 @@
|
|||
(cond
|
||||
[(and (eq? type 'symbol)
|
||||
(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)]
|
||||
[else
|
||||
(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)
|
||||
;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
|
||||
(define (get-head-sexp-type-from-prefs text pref)
|
||||
;; get-keyword-type : string (list ht regexp regexp regexp)
|
||||
;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
|
||||
(define (get-keyword-type text pref)
|
||||
(define ht (car pref))
|
||||
(define beg-reg (list-ref pref 1))
|
||||
(define def-reg (list-ref pref 2))
|
||||
|
|
|
|||
|
|
@ -1,116 +1,99 @@
|
|||
#lang racket/base
|
||||
#lang scheme/base
|
||||
(require racket/contract/base
|
||||
racket/class
|
||||
racket/gui/base)
|
||||
scheme/gui/base)
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[find-string-embedded
|
||||
(->* ((is-a?/c text%)
|
||||
string?)
|
||||
((or/c 'forward 'backward)
|
||||
(or/c 'start number?)
|
||||
(or/c 'eof number?)
|
||||
boolean?
|
||||
boolean?
|
||||
boolean?)
|
||||
(values (is-a?/c editor<%>)
|
||||
(or/c #f number?)))]))
|
||||
(provide/contract
|
||||
[find-string-embedded
|
||||
(->* ((is-a?/c text%)
|
||||
string?)
|
||||
((symbols 'forward 'backward)
|
||||
(or/c (symbols 'start) number?)
|
||||
(or/c (symbols 'eof) number?)
|
||||
boolean?
|
||||
boolean?
|
||||
boolean?)
|
||||
(values (is-a?/c editor<%>)
|
||||
(or/c false/c number?)))])
|
||||
|
||||
(define (find-string-embedded a-text
|
||||
str
|
||||
[direction 'forward]
|
||||
[start 'start]
|
||||
[end 'eof]
|
||||
[get-start #t]
|
||||
[case-sensitive? #t]
|
||||
[pop-out? #f])
|
||||
(let/ec k
|
||||
(let loop ([a-text a-text]
|
||||
[start start]
|
||||
[end end])
|
||||
(define found (send a-text find-string-embedded str direction start end get-start case-sensitive?))
|
||||
(define (done)
|
||||
(cond
|
||||
[(not found)
|
||||
(k a-text found)]
|
||||
[else
|
||||
(let loop ([a-text a-text]
|
||||
[found found])
|
||||
(cond
|
||||
[(number? found)
|
||||
(k a-text found)]
|
||||
[else (loop (car found) (cdr found))]))]))
|
||||
(when found (done))
|
||||
(unless pop-out? (done))
|
||||
(define a-text-admin (send a-text get-admin))
|
||||
(unless (is-a? a-text-admin editor-snip-editor-admin<%>) (done))
|
||||
(define editor-snip (send a-text-admin get-snip))
|
||||
(define editor-snip-admin (send editor-snip get-admin))
|
||||
(unless editor-snip-admin (done))
|
||||
(define enclosing-text (send editor-snip-admin get-editor))
|
||||
(unless (is-a? enclosing-text text%) (done))
|
||||
(loop enclosing-text
|
||||
(+ (send enclosing-text get-snip-position editor-snip)
|
||||
(send editor-snip get-count))
|
||||
'eof))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define abcX (new text%))
|
||||
(send abcX insert "abcX")
|
||||
|
||||
(define abc/abcX/abcQ (new text%))
|
||||
(send abc/abcX/abcQ insert "abc")
|
||||
(send abc/abcX/abcQ insert (new editor-snip% [editor abcX]))
|
||||
(send abc/abcX/abcQ insert "abcQ")
|
||||
|
||||
(define abc//abc/abcX/abcQ//abcZ (new text%))
|
||||
(send abc//abc/abcX/abcQ//abcZ insert "abc")
|
||||
(send abc//abc/abcX/abcQ//abcZ insert (new editor-snip% [editor abc/abcX/abcQ]))
|
||||
(send abc//abc/abcX/abcQ//abcZ insert "abcZ")
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "b" 'forward 0))
|
||||
(check-equal? ta abcX)
|
||||
(check-equal? pos 1))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 0))
|
||||
(check-equal? ta abcX)
|
||||
(check-equal? pos 2))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "d" 'forward 2))
|
||||
(check-equal? pos #f))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0))
|
||||
(check-equal? ta ta)
|
||||
(check-equal? pos 1))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2))
|
||||
(check-equal? ta abcX)
|
||||
(check-equal? pos 1))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0))
|
||||
(check-equal? ta abcX)
|
||||
(check-equal? pos 3))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t))
|
||||
(check-equal? ta abc/abcX/abcQ)
|
||||
(check-equal? pos 7))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t))
|
||||
(check-equal? ta abc//abc/abcX/abcQ//abcZ)
|
||||
(check-equal? pos 7))
|
||||
|
||||
(let ()
|
||||
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t))
|
||||
(check-equal? ta abc/abcX/abcQ)
|
||||
(check-equal? pos 6)))
|
||||
(define find-string-embedded
|
||||
(lambda (edit
|
||||
str
|
||||
[direction 'forward]
|
||||
[start 'start]
|
||||
[end 'eof]
|
||||
[get-start #t]
|
||||
[case-sensitive? #t]
|
||||
[pop-out? #f])
|
||||
(let/ec k
|
||||
(let* ([start (if (eq? start 'start)
|
||||
(send edit get-start-position)
|
||||
start)]
|
||||
[end (if (eq? 'eof end)
|
||||
(if (eq? direction 'forward)
|
||||
(send edit last-position)
|
||||
0)
|
||||
end)]
|
||||
[flat (send edit find-string str direction
|
||||
start end get-start
|
||||
case-sensitive?)]
|
||||
[pop-out
|
||||
(λ ()
|
||||
(let ([admin (send edit get-admin)])
|
||||
(if (is-a? admin editor-snip-editor-admin<%>)
|
||||
(let* ([snip (send admin get-snip)]
|
||||
[edit-above (send (send snip get-admin) get-editor)]
|
||||
[pos (send edit-above get-snip-position snip)]
|
||||
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)])
|
||||
(find-string-embedded
|
||||
edit-above
|
||||
str
|
||||
direction
|
||||
pop-out-pos
|
||||
(if (eq? direction 'forward) 'eof 0)
|
||||
get-start
|
||||
case-sensitive?
|
||||
pop-out?))
|
||||
(values edit #f))))])
|
||||
(let loop ([current-snip (send edit find-snip start
|
||||
(if (eq? direction 'forward)
|
||||
'after-or-none
|
||||
'before-or-none))])
|
||||
(let ([next-loop
|
||||
(λ ()
|
||||
(if (eq? direction 'forward)
|
||||
(loop (send current-snip next))
|
||||
(loop (send current-snip previous))))])
|
||||
(cond
|
||||
[(or (not current-snip)
|
||||
(and flat
|
||||
(let* ([start (send edit get-snip-position current-snip)]
|
||||
[end (+ start (send current-snip get-count))])
|
||||
(if (eq? direction 'forward)
|
||||
(and (<= start flat)
|
||||
(< flat end))
|
||||
(and (< start flat)
|
||||
(<= flat end))))))
|
||||
(if (and (not flat) pop-out?)
|
||||
(pop-out)
|
||||
(values edit flat))]
|
||||
[(is-a? current-snip editor-snip%)
|
||||
(let-values ([(embedded embedded-pos)
|
||||
(let ([media (send current-snip get-editor)])
|
||||
(if (and media
|
||||
(is-a? media text%))
|
||||
(begin
|
||||
(find-string-embedded
|
||||
media
|
||||
str
|
||||
direction
|
||||
(if (eq? 'forward direction)
|
||||
0
|
||||
(send media last-position))
|
||||
'eof
|
||||
get-start case-sensitive?))
|
||||
(values #f #f)))])
|
||||
(if (not embedded-pos)
|
||||
(next-loop)
|
||||
(values embedded embedded-pos)))]
|
||||
[else (next-loop)])))))))
|
||||
|
|
|
|||
|
|
@ -182,7 +182,6 @@
|
|||
(define-signature text-class^
|
||||
(basic<%>
|
||||
line-spacing<%>
|
||||
ascii-art-enlarge-boxes<%>
|
||||
first-line<%>
|
||||
line-numbers<%>
|
||||
foreground-color<%>
|
||||
|
|
@ -226,7 +225,6 @@
|
|||
|
||||
basic-mixin
|
||||
line-spacing-mixin
|
||||
ascii-art-enlarge-boxes-mixin
|
||||
first-line-mixin
|
||||
line-numbers-mixin
|
||||
foreground-color-mixin
|
||||
|
|
@ -261,8 +259,7 @@
|
|||
range-color
|
||||
|
||||
make-snip-special
|
||||
snip-special?
|
||||
send-snip-to-port))
|
||||
snip-special?))
|
||||
|
||||
(define-signature canvas-class^
|
||||
(basic<%>
|
||||
|
|
|
|||
|
|
@ -12,11 +12,9 @@
|
|||
"autocomplete.rkt"
|
||||
mred/mred-sig
|
||||
mrlib/interactive-value-port
|
||||
(prefix-in image-core: mrlib/image-core)
|
||||
racket/list
|
||||
"logging-timer.rkt"
|
||||
"coroutine.rkt"
|
||||
"unicode-ascii-art.rkt"
|
||||
data/queue
|
||||
racket/unit)
|
||||
|
||||
|
|
@ -871,89 +869,6 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define ascii-art-enlarge-boxes<%> text:ascii-art-enlarge-boxes<%>)
|
||||
|
||||
(define ascii-art-enlarge-boxes-mixin
|
||||
(mixin ((class->interface text%)) (ascii-art-enlarge-boxes<%>)
|
||||
(inherit get-overwrite-mode set-overwrite-mode
|
||||
get-start-position get-end-position set-position last-position
|
||||
get-character
|
||||
begin-edit-sequence end-edit-sequence
|
||||
position-paragraph paragraph-start-position)
|
||||
|
||||
(define ascii-art-enlarge? (preferences:get 'framework:ascii-art-enlarge))
|
||||
(define/public (get-ascii-art-enlarge) ascii-art-enlarge?)
|
||||
(define/public (set-ascii-art-enlarge _e?)
|
||||
(define e? (and _e? #t))
|
||||
(preferences:set 'framework:ascii-art-enlarge e?)
|
||||
(set! ascii-art-enlarge? e?))
|
||||
|
||||
(define/override (on-default-char c)
|
||||
(define kc (send c get-key-code))
|
||||
(define overwrite? (get-overwrite-mode))
|
||||
(cond
|
||||
[(not ascii-art-enlarge?) (super on-default-char c)]
|
||||
[(or (and (char? kc)
|
||||
(not (member kc '(#\return #\tab #\backspace #\rubout))))
|
||||
(member (send c get-key-code)
|
||||
going-to-insert-something))
|
||||
(begin-edit-sequence)
|
||||
(define pos (get-start-position))
|
||||
(define widen? (and (= pos (get-end-position))
|
||||
(or (not overwrite?)
|
||||
(insertion-point-at-double-barred-char?))))
|
||||
(when widen?
|
||||
(define para (position-paragraph pos))
|
||||
(define delta-from-start (- pos (paragraph-start-position para)))
|
||||
(widen-unicode-ascii-art-box this pos)
|
||||
(define new-pos (+ (paragraph-start-position para) delta-from-start))
|
||||
(set-position new-pos new-pos))
|
||||
(unless overwrite? (set-overwrite-mode #t))
|
||||
(super on-default-char c)
|
||||
(unless overwrite? (set-overwrite-mode #f))
|
||||
(end-edit-sequence)]
|
||||
[else
|
||||
(super on-default-char c)]))
|
||||
|
||||
(define/override (on-local-char c)
|
||||
(define kc (send c get-key-code))
|
||||
(define overwrite? (get-overwrite-mode))
|
||||
(cond
|
||||
[(not ascii-art-enlarge?) (super on-local-char c)]
|
||||
[(member kc '(numpad-enter #\return))
|
||||
(define pos (get-start-position))
|
||||
(cond
|
||||
[(= pos (get-end-position))
|
||||
(heighten-unicode-ascii-art-box this pos)
|
||||
(define pos-para (position-paragraph pos))
|
||||
(define pos-para-start (paragraph-start-position pos-para))
|
||||
(define next-para-start (paragraph-start-position (+ pos-para 1)))
|
||||
(define just-below-pos (+ next-para-start (- pos pos-para-start)))
|
||||
(define new-pos
|
||||
(let loop ([pos just-below-pos])
|
||||
(cond
|
||||
[(<= pos next-para-start)
|
||||
pos]
|
||||
[(equal? (get-character (- pos 1)) #\║)
|
||||
pos]
|
||||
[else (loop (- pos 1))])))
|
||||
(set-position new-pos new-pos)]
|
||||
[else
|
||||
(super on-local-char c)])]
|
||||
[else
|
||||
(super on-local-char c)]))
|
||||
|
||||
(define/private (insertion-point-at-double-barred-char?)
|
||||
(define sp (get-start-position))
|
||||
(and (< sp (last-position))
|
||||
(equal? (get-character sp) #\║)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define going-to-insert-something
|
||||
'(multiply
|
||||
add subtract decimal divide
|
||||
numpad0 numpad1 numpad2 numpad3 numpad4 numpad5 numpad6 numpad7 numpad8 numpad9))
|
||||
|
||||
(define foreground-color<%>
|
||||
(interface (basic<%> editor:standard-style-list<%>)
|
||||
|
|
@ -1222,7 +1137,7 @@
|
|||
get-start-position get-end-position
|
||||
unhighlight-ranges/key unhighlight-range highlight-range
|
||||
run-after-edit-sequence begin-edit-sequence end-edit-sequence
|
||||
find-string find-string-embedded get-admin position-line
|
||||
find-string get-admin position-line
|
||||
in-edit-sequence? get-pos/text-dc-location
|
||||
get-canvas get-top-level-window)
|
||||
|
||||
|
|
@ -1263,7 +1178,7 @@
|
|||
(car to-replace-highlight)))
|
||||
|
||||
;; NEW METHOD: used for test suites
|
||||
(define/public (search-updates-pending?)
|
||||
(define/public (search-updates-pending?)
|
||||
(or update-replace-bubble-callback-running?
|
||||
search-position-callback-running?
|
||||
search-coroutine))
|
||||
|
|
@ -1352,16 +1267,16 @@
|
|||
(when to-replace-highlight
|
||||
(unhighlight-replace))]
|
||||
[else
|
||||
(define next (do-search (get-start-position)))
|
||||
(define next (do-search (get-start-position) 'eof))
|
||||
(begin-edit-sequence #t #f)
|
||||
(cond
|
||||
[(number? next)
|
||||
[next
|
||||
(unless (and to-replace-highlight
|
||||
(= (car to-replace-highlight) next)
|
||||
(= (cdr to-replace-highlight)
|
||||
(string-length searching-str)))
|
||||
(+ next (string-length searching-str))))
|
||||
(replace-highlight->normal-hit)
|
||||
(define pr (cons next (string-length searching-str)))
|
||||
(define pr (cons next (+ next (string-length searching-str))))
|
||||
(unhighlight-hit pr)
|
||||
(highlight-replace pr))]
|
||||
[else
|
||||
|
|
@ -1378,27 +1293,16 @@
|
|||
(queue-callback
|
||||
(λ ()
|
||||
(when searching-str
|
||||
(define start-pos (get-focus-editor-start-position))
|
||||
(define count
|
||||
(for/sum ([(k v) (in-hash search-bubble-table)])
|
||||
(define n (if (search-result-compare <= (car k) start-pos) 1 0))
|
||||
n))
|
||||
(define count 0)
|
||||
(define start-pos (get-start-position))
|
||||
(hash-for-each
|
||||
search-bubble-table
|
||||
(λ (k v)
|
||||
(when (<= (car k) start-pos)
|
||||
(set! count (+ count 1)))))
|
||||
(update-before-caret-search-hit-count count))
|
||||
(set! search-position-callback-running? #f))
|
||||
#f)))
|
||||
|
||||
(define/private (get-focus-editor-start-position)
|
||||
(let loop ([txt this])
|
||||
(define focus (send txt get-focus-snip))
|
||||
(define embedded
|
||||
(and focus
|
||||
(is-a? focus editor-snip%)
|
||||
(is-a? (send focus get-editor) text%)
|
||||
(send focus get-editor)))
|
||||
(cond
|
||||
[embedded
|
||||
(cons embedded (loop embedded))]
|
||||
[else (send txt get-start-position)])))
|
||||
|
||||
(define/private (update-before-caret-search-hit-count c)
|
||||
(unless (equal? before-caret-search-hit-count c)
|
||||
|
|
@ -1425,7 +1329,7 @@
|
|||
(clear-yellow)
|
||||
(set! clear-yellow void)
|
||||
(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
|
||||
start end
|
||||
(if (preferences:get 'framework:white-on-black?)
|
||||
|
|
@ -1444,7 +1348,7 @@
|
|||
(list (list to-replace-highlight 'dark-search-color))
|
||||
(list))
|
||||
(hash-map search-bubble-table
|
||||
(λ (x _true)
|
||||
(λ (x true)
|
||||
(list x (if replace-mode? 'light-search-color 'normal-search-color)))))
|
||||
string<?
|
||||
#:key (λ (x) (format "~s" (car x)))))
|
||||
|
|
@ -1509,40 +1413,31 @@
|
|||
[searching-str
|
||||
(define new-search-bubbles '())
|
||||
(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)
|
||||
(cond
|
||||
[first-hit
|
||||
(define sp (get-focus-editor-start-position))
|
||||
(define sp (get-start-position))
|
||||
(let loop ([bubble-start first-hit]
|
||||
[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)
|
||||
(define bubble-end (search-result+ bubble-start (string-length searching-str)))
|
||||
(define bubble (cons bubble-start (string-length searching-str)))
|
||||
(define bubble-end (+ bubble-start (string-length searching-str)))
|
||||
(define bubble (cons bubble-start bubble-end))
|
||||
(define this-bubble
|
||||
(cond
|
||||
[(and replace-mode?
|
||||
(not new-replace-bubble)
|
||||
(search-result-compare <= sp bubble-start))
|
||||
(<= sp bubble-start))
|
||||
(set! new-replace-bubble bubble)
|
||||
'the-replace-bubble]
|
||||
[else
|
||||
bubble]))
|
||||
(set! new-search-bubbles (cons this-bubble new-search-bubbles))
|
||||
|
||||
(define next (do-search bubble-end))
|
||||
|
||||
(when (> (let loop ([x bubble-start])
|
||||
(cond
|
||||
[(number? x) 1]
|
||||
[else (+ 1 (loop (cdr x)))]))
|
||||
3)
|
||||
(car))
|
||||
|
||||
|
||||
(define next (do-search bubble-end 'eof))
|
||||
(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)
|
||||
before-caret-search-hit-count))
|
||||
(cond
|
||||
|
|
@ -1592,82 +1487,15 @@
|
|||
(send w search-hits-changed)]
|
||||
[(is-a? w area<%>)
|
||||
(loop (send w get-parent))]))))))
|
||||
|
||||
(define/private (search-result+ search-result num)
|
||||
(let loop ([search-result search-result])
|
||||
(cond
|
||||
[(number? search-result) (+ search-result num)]
|
||||
[(cons? search-result)
|
||||
(cons (car search-result)
|
||||
(loop (cdr search-result)))])))
|
||||
|
||||
(define/private (search-result-compare lt l r)
|
||||
(let loop ([txt this]
|
||||
[l l]
|
||||
[r r])
|
||||
(define (get-the-position x)
|
||||
;; the zeros shouldn't happen because the editors should still
|
||||
;; be in the main text object while we are doing stuff with them
|
||||
(define admin (send x get-admin))
|
||||
(cond
|
||||
[(is-a? admin editor-snip-editor-admin<%>)
|
||||
(or (send txt get-snip-position (send admin get-snip)) 0)]
|
||||
[else
|
||||
0]))
|
||||
(cond
|
||||
[(and (number? l) (number? r)) (lt l r)]
|
||||
[(or (number? l) (number? r))
|
||||
(define ln (if (number? l) l (get-the-position (car l))))
|
||||
(define rn (if (number? r) r (get-the-position (car r))))
|
||||
(lt ln rn)]
|
||||
[else
|
||||
(cond
|
||||
[(equal? (car l) (car r))
|
||||
(loop (car l) (cdr l) (cdr r))]
|
||||
[else
|
||||
(lt (get-the-position (car l))
|
||||
(get-the-position (car r)))])])))
|
||||
|
||||
(define all-txt-with-regions-to-clear (make-hasheq))
|
||||
|
||||
(define/private (clear-all-regions)
|
||||
(when to-replace-highlight
|
||||
(unhighlight-replace))
|
||||
(for ([(txt _) (in-hash all-txt-with-regions-to-clear)])
|
||||
(send txt unhighlight-ranges/key 'plt:framework:search-bubbles))
|
||||
(set! all-txt-with-regions-to-clear (make-hasheq))
|
||||
(unhighlight-ranges/key 'plt:framework:search-bubbles)
|
||||
(set! search-bubble-table (make-hash)))
|
||||
|
||||
(define/private (do-search start)
|
||||
(define context (list this))
|
||||
(define position
|
||||
(let loop ([start start])
|
||||
(cond
|
||||
[(number? start) start]
|
||||
[else
|
||||
(set! context (cons (car start) context))
|
||||
(loop (cdr start))])))
|
||||
(let loop ([position position]
|
||||
[context context])
|
||||
(define found-at-this-level
|
||||
(send (car context) find-string-embedded searching-str 'forward position 'eof #t case-sensitive?))
|
||||
(cond
|
||||
[found-at-this-level
|
||||
(let loop ([context context])
|
||||
(cond
|
||||
[(null? (cdr context)) found-at-this-level]
|
||||
[else (cons (car context)
|
||||
(loop (cdr context)))]))]
|
||||
[(null? (cdr context)) #f]
|
||||
[else
|
||||
(define admin (send (car context) get-admin))
|
||||
(cond
|
||||
[(is-a? admin editor-snip-editor-admin<%>)
|
||||
(define snip (send admin get-snip))
|
||||
(loop (+ (send (second context) get-snip-position snip)
|
||||
(send snip get-count))
|
||||
(cdr context))]
|
||||
[else
|
||||
(error 'framework/private/text.rkt::searching "admin went wrong ~s" admin)])])))
|
||||
(define/private (do-search start end)
|
||||
(find-string searching-str 'forward start end #t case-sensitive?))
|
||||
|
||||
;; INVARIANT: when a search bubble is highlighted,
|
||||
;; 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)
|
||||
;; but only when there is a pending "erase all highlights and recompute everything" callback
|
||||
(define/private (unhighlight-hit bubble)
|
||||
(hash-remove! search-bubble-table bubble)
|
||||
(define-values (txt start end) (get-highlighting-text-and-range bubble))
|
||||
(when txt
|
||||
(send txt unhighlight-range
|
||||
start end
|
||||
(if replace-mode? light-search-color normal-search-color)
|
||||
#f
|
||||
'hollow-ellipse)))
|
||||
(define/private (highlight-hit bubble)
|
||||
(hash-set! search-bubble-table bubble #t)
|
||||
(define-values (txt start end) (get-highlighting-text-and-range bubble))
|
||||
(when txt
|
||||
(hash-set! all-txt-with-regions-to-clear txt #t)
|
||||
(send txt highlight-range
|
||||
start end
|
||||
(if replace-mode? light-search-color normal-search-color)
|
||||
#f
|
||||
'low
|
||||
'hollow-ellipse
|
||||
#:key 'plt:framework:search-bubbles
|
||||
#:adjust-on-insert/delete? #t)))
|
||||
(define/private (unhighlight-hit pair)
|
||||
(hash-remove! search-bubble-table pair)
|
||||
(unhighlight-range (car pair) (cdr pair)
|
||||
(if replace-mode? light-search-color normal-search-color)
|
||||
#f
|
||||
'hollow-ellipse))
|
||||
(define/private (highlight-hit pair)
|
||||
(hash-set! search-bubble-table pair #t)
|
||||
(highlight-range (car pair) (cdr pair)
|
||||
(if replace-mode? light-search-color normal-search-color)
|
||||
#f
|
||||
'low
|
||||
'hollow-ellipse
|
||||
#:key 'plt:framework:search-bubbles
|
||||
#:adjust-on-insert/delete? #t))
|
||||
|
||||
;; INVARIANT: the "next to replace" highlight is always
|
||||
;; saved in 'to-replace-highlight'
|
||||
(define/private (unhighlight-replace)
|
||||
(define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight))
|
||||
(when txt
|
||||
(send txt unhighlight-range
|
||||
start end
|
||||
dark-search-color
|
||||
#f
|
||||
'hollow-ellipse))
|
||||
(unhighlight-range (car to-replace-highlight)
|
||||
(cdr to-replace-highlight)
|
||||
dark-search-color
|
||||
#f
|
||||
'hollow-ellipse)
|
||||
(set! to-replace-highlight #f))
|
||||
|
||||
(define/private (highlight-replace new-to-replace)
|
||||
(set! to-replace-highlight new-to-replace)
|
||||
(define-values (txt start end) (get-highlighting-text-and-range new-to-replace))
|
||||
(when txt
|
||||
(send txt highlight-range
|
||||
start end
|
||||
dark-search-color
|
||||
#f
|
||||
'high
|
||||
'hollow-ellipse)))
|
||||
|
||||
(define/private (get-highlighting-text-and-range bubble)
|
||||
(let loop ([txt this]
|
||||
[txt/pr (car bubble)])
|
||||
(cond
|
||||
[(number? txt/pr)
|
||||
(if (is-a? txt text:basic<%>)
|
||||
(values txt txt/pr (+ txt/pr (cdr bubble)))
|
||||
(values #f #f #f))]
|
||||
[else (loop (car txt/pr) (cdr txt/pr))])))
|
||||
(highlight-range (car to-replace-highlight)
|
||||
(cdr to-replace-highlight)
|
||||
dark-search-color
|
||||
#f
|
||||
'high
|
||||
'hollow-ellipse))
|
||||
|
||||
(define/private (unhighlight-anchor)
|
||||
(unhighlight-range anchor-pos anchor-pos "red" #f 'dot)
|
||||
|
|
@ -2463,29 +2270,22 @@
|
|||
[the-snipclass
|
||||
(define base (new editor-stream-out-bytes-base%))
|
||||
(define stream (make-object editor-stream-out% base))
|
||||
(write-editor-global-header stream)
|
||||
(send snip write stream)
|
||||
(write-editor-global-footer stream)
|
||||
(snip-special snip
|
||||
(send the-snipclass get-classname)
|
||||
(send base get-bytes))]
|
||||
[else
|
||||
(snip-special snip #f #f)]))
|
||||
;; -> (or/c (is-a?/c snip%) exn:fail?)
|
||||
(define (snip-special->snip snip-special)
|
||||
(define the-name (snip-special-name snip-special))
|
||||
(define snipclass (and the-name (send (get-the-snip-class-list) find the-name)))
|
||||
(cond
|
||||
[snipclass
|
||||
(with-handlers ([exn:fail? values])
|
||||
(define base (make-object editor-stream-in-bytes-base%
|
||||
(snip-special-bytes snip-special)))
|
||||
(define es (make-object editor-stream-in% base))
|
||||
(read-editor-global-header es)
|
||||
(define the-snip (send snipclass read es))
|
||||
(read-editor-global-footer es)
|
||||
(or the-snip
|
||||
(snip-special-snip snip-special)))]
|
||||
(define base (make-object editor-stream-in-bytes-base%
|
||||
(snip-special-bytes snip-special)))
|
||||
(define es (make-object editor-stream-in% base))
|
||||
(or (send snipclass read es)
|
||||
(snip-special-snip snip-special))]
|
||||
[else
|
||||
(snip-special-snip snip-special)]))
|
||||
|
||||
|
|
@ -2839,7 +2639,7 @@
|
|||
(define/private (do-insertion txts showing-input?)
|
||||
(define locked? (is-locked?))
|
||||
(define sf? (get-styles-fixed))
|
||||
(begin-edit-sequence #f)
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(set-styles-fixed #f)
|
||||
(set! allow-edits? #t)
|
||||
|
|
@ -2848,26 +2648,12 @@
|
|||
[(null? txts) (void)]
|
||||
[else
|
||||
(define fst (car txts))
|
||||
(define-values (str/snp style)
|
||||
(define str/snp
|
||||
(cond
|
||||
[(snip-special? (car fst))
|
||||
(define the-snip
|
||||
(snip-special->snip (car fst)))
|
||||
(if (exn:fail? the-snip)
|
||||
(values (apply
|
||||
string-append
|
||||
"error while rendering snip "
|
||||
(format "~s" (snip-special-name (car fst)))
|
||||
":\n"
|
||||
(exn-message the-snip)
|
||||
" context:\n"
|
||||
(for/list ([x (in-list (continuation-mark-set->context
|
||||
(exn-continuation-marks
|
||||
the-snip)))])
|
||||
(format " ~s\n" x)))
|
||||
(add-standard error-style-name))
|
||||
(values the-snip (cdr fst)))]
|
||||
[else (values (car fst) (cdr fst))]))
|
||||
(snip-special->snip (car fst))]
|
||||
[else (car fst)]))
|
||||
(define style (cdr fst))
|
||||
|
||||
(define inserted-count
|
||||
(if (is-a? str/snp snip%)
|
||||
|
|
@ -3075,8 +2861,8 @@
|
|||
;; don't want to set the port-print-handler here;
|
||||
;; instead drracket sets the global-port-print-handler
|
||||
;; to catch fractions and the like
|
||||
(set-interactive-write-handler port #:snip-handler send-snip-to-port)
|
||||
(set-interactive-display-handler port #:snip-handler send-snip-to-port))])
|
||||
(set-interactive-write-handler port)
|
||||
(set-interactive-display-handler port))])
|
||||
(install-handlers out-port)
|
||||
(install-handlers err-port)
|
||||
(install-handlers value-port))))
|
||||
|
|
@ -3215,30 +3001,6 @@
|
|||
(define in-port (make-in-port-with-a-name (get-port-name)))
|
||||
(define in-box-port (make-in-box-port-with-a-name (get-port-name)))))
|
||||
|
||||
(define (send-snip-to-port value port)
|
||||
(cond
|
||||
[(image-core:image? value)
|
||||
;; do this computation here so that any failures
|
||||
;; during drawing happen under the user's custodian
|
||||
(image-core:compute-image-cache value)
|
||||
|
||||
;; once that is done, we trust the value not to run
|
||||
;; any code that the user wrote, so just send it over
|
||||
(write-special value port)]
|
||||
[else
|
||||
(define str (format "~s" value))
|
||||
(cond
|
||||
;; special case these snips as they don't work properly
|
||||
;; without this and we aren't ready to break them yet
|
||||
;; and image-core:image? should be safe-- there is no user
|
||||
;; code in those images to fail
|
||||
[(or (regexp-match? #rx"plot-snip%" str)
|
||||
(regexp-match? #rx"pict3d%" str))
|
||||
(write-special (send value copy) port)]
|
||||
[else
|
||||
(write-special (make-snip-special (send value copy)) port)])])
|
||||
(void))
|
||||
|
||||
(define input-box<%>
|
||||
(interface ((class->interface text%))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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,7 +4,7 @@
|
|||
|
||||
(define deps '("srfi-lite-lib"
|
||||
"data-lib"
|
||||
["base" #:version "6.5.0.2"]
|
||||
["base" #:version "6.4"]
|
||||
"syntax-color-lib"
|
||||
["draw-lib" #:version "1.13"]
|
||||
["snip-lib" #:version "1.2"]
|
||||
|
|
@ -30,4 +30,4 @@
|
|||
|
||||
(define pkg-authors '(mflatt robby))
|
||||
|
||||
(define version "1.28")
|
||||
(define version "1.24")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang info
|
||||
|
||||
(define version '(400))
|
||||
(define install-collection "installer.rkt")
|
||||
(define post-install-collection "installer.rkt")
|
||||
(define copy-man-pages '("mred.1"))
|
||||
|
||||
(define release-note-files
|
||||
|
|
|
|||
|
|
@ -3,71 +3,44 @@
|
|||
compiler/embed
|
||||
racket/file
|
||||
racket/path
|
||||
setup/dirs
|
||||
setup/cross-system)
|
||||
|
||||
(provide installer)
|
||||
(provide post-installer)
|
||||
|
||||
;; Platforms that get a `MrEd' executable:
|
||||
(define mred-exe-systems '(unix))
|
||||
|
||||
(define (installer path coll user? no-main?)
|
||||
(unless no-main?
|
||||
(do-installer path coll user? #f)
|
||||
(when (and (not user?)
|
||||
(find-config-tethered-console-bin-dir))
|
||||
(do-installer path coll #f #t)))
|
||||
(when (find-addon-tethered-console-bin-dir)
|
||||
(do-installer path coll #t #t)))
|
||||
|
||||
(define (do-installer path coll user? tethered?)
|
||||
(define (post-installer path coll user?)
|
||||
(define variants (available-mred-variants))
|
||||
(when (memq (cross-system-type) mred-exe-systems)
|
||||
(for ([v variants] #:when (memq v '(3m cgc)))
|
||||
(parameterize ([current-launcher-variant v])
|
||||
(create-embedding-executable
|
||||
(prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
|
||||
#:cmdline (append
|
||||
(if tethered? (if user? (addon-flags) (config-flags)) null)
|
||||
'("-I" "scheme/gui/init"))
|
||||
(prep-dir (mred-program-launcher-path "MrEd" #:user? user?))
|
||||
#:cmdline '("-I" "scheme/gui/init")
|
||||
#:variant v
|
||||
#:launcher? #t
|
||||
#:gracket? #t
|
||||
#:aux `((relative? . ,(not user?)))))))
|
||||
;; add a mred-text executable that uses the -z flag (preferring a script)
|
||||
(define tether-mode (and tethered? (if user? 'addon 'config)))
|
||||
(for ([vs '((script-3m 3m) (script-cgc cgc))])
|
||||
(let ([v (findf (lambda (v) (memq v variants)) vs)])
|
||||
(when v
|
||||
(parameterize ([current-launcher-variant v])
|
||||
(make-gracket-launcher
|
||||
#:tether-mode tether-mode
|
||||
'("-I" "scheme/gui/init" "-z")
|
||||
(prep-dir (mred-program-launcher-path "mred-text" #:user? user? #:tethered? tethered?))
|
||||
`([relative? . ,(not (or user? tethered?))]
|
||||
[subsystem . console]
|
||||
[single-instance? . #f]))))))
|
||||
(prep-dir (mred-program-launcher-path "mred-text" #:user? user?))
|
||||
`([relative? . ,(not user?)] [subsystem . console] [single-instance? . #f]))))))
|
||||
;; add bin/mred script under OS X
|
||||
(when (eq? 'macosx (cross-system-type))
|
||||
(for ([v variants] #:when (memq v '(script-3m script-cgc)))
|
||||
(parameterize ([current-launcher-variant v])
|
||||
(make-gracket-launcher
|
||||
#:tether-mode tether-mode
|
||||
null
|
||||
(prep-dir (mred-program-launcher-path "MrEd" #:user? user? #:tethered? tethered?))
|
||||
`([exe-name . "GRacket"]
|
||||
[relative? . ,(not (or user? tethered?))]
|
||||
[exe-is-gracket . #t]))))))
|
||||
'()
|
||||
(prep-dir (mred-program-launcher-path "MrEd" #:user? user?))
|
||||
'([exe-name . "GRacket"] [relative? . ,(not user?)] [exe-is-gracket . #t]))))))
|
||||
|
||||
(define (prep-dir p)
|
||||
(define dir (path-only p))
|
||||
(make-directory* dir)
|
||||
p)
|
||||
|
||||
(define (addon-flags)
|
||||
(append
|
||||
(config-flags)
|
||||
(list "-A" (path->string (find-system-path 'addon-dir)))))
|
||||
|
||||
(define (config-flags)
|
||||
(list "-C" (path->string (find-config-dir))))
|
||||
|
|
|
|||
|
|
@ -182,29 +182,14 @@
|
|||
panel))]
|
||||
[as-canvas? (lambda () (or (memq 'vscroll style)
|
||||
(memq 'auto-vscroll style)
|
||||
(memq 'hide-vscroll style)
|
||||
(memq 'hscroll style)
|
||||
(memq 'auto-hscroll style)
|
||||
(memq 'hide-hscroll style)))])
|
||||
(memq 'auto-hscroll style)))])
|
||||
(check-container-parent cwho parent)
|
||||
(check-style cwho #f (append '(border deleted)
|
||||
(if can-canvas?
|
||||
'(hscroll vscroll
|
||||
auto-hscroll auto-vscroll
|
||||
hide-hscroll hide-vscroll)
|
||||
'(hscroll vscroll auto-hscroll auto-vscroll)
|
||||
null))
|
||||
style)
|
||||
|
||||
(define (add-scrolls style)
|
||||
(append
|
||||
(if (memq 'hide-vscroll style)
|
||||
'(auto-vscroll)
|
||||
null)
|
||||
(if (memq 'hide-hscroll style)
|
||||
'(auto-hscroll)
|
||||
null)
|
||||
style))
|
||||
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
|
|
@ -223,7 +208,7 @@
|
|||
wx-canvas-panel%
|
||||
wx-panel%)])
|
||||
this this (mred->wx-container parent)
|
||||
(cons 'transparent (add-scrolls style))
|
||||
(cons 'transparent style)
|
||||
(get-initial-label)))
|
||||
wx)
|
||||
(lambda () wx)
|
||||
|
|
|
|||
|
|
@ -621,13 +621,11 @@
|
|||
|
||||
(define enabled? #t)
|
||||
(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?)
|
||||
(send parent is-enabled-to-root?))
|
||||
(define/public (is-window-enabled?/raw)
|
||||
enabled?)
|
||||
(define/public (is-window-enabled?)
|
||||
(is-window-enabled?/raw))
|
||||
enabled?)
|
||||
(define/public (enable on?)
|
||||
(atomically
|
||||
(set! enabled? on?)
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@
|
|||
(if (caps . < . 0) "~l:" "")
|
||||
(if (altgr . > . 0) "g:" "")
|
||||
(if (altgr . < . 0) "~g:" "")
|
||||
(or (hash-ref rev-keylist code #f)
|
||||
(or (hash-ref rev-keylist code)
|
||||
(format "~c" code)))])
|
||||
(error (method-name 'keymap% 'map-function)
|
||||
"~s is already mapped as a ~aprefix key"
|
||||
|
|
|
|||
|
|
@ -381,15 +381,6 @@
|
|||
(unless recur? (inc-item-count))
|
||||
(let ([s (with-handlers ([exn:fail:read? (lambda (x) #f)])
|
||||
(read si))])
|
||||
(when (and recur? s)
|
||||
;; It's ok to have extra whitespace when reading a byte
|
||||
;; string in a sequence
|
||||
(let loop ()
|
||||
(define c (peek-byte si))
|
||||
(unless (eof-object? c)
|
||||
(when (char-whitespace? (integer->char c))
|
||||
(read-byte si)
|
||||
(loop)))))
|
||||
(if (or (not s)
|
||||
(not (eof-object? (read-byte si))))
|
||||
(fail)
|
||||
|
|
|
|||
|
|
@ -97,17 +97,13 @@
|
|||
|
||||
(define ignore-redraw-request? #f)
|
||||
|
||||
(define hide-scroll-x? (and (memq 'hide-hscroll style) #t))
|
||||
(define hide-scroll-y? (and (memq 'hide-vscroll style) #t))
|
||||
|
||||
(define auto-scroll-x? (and (memq 'auto-hscroll style) #t))
|
||||
(define auto-scroll-y? (and (memq 'auto-vscroll style) #t))
|
||||
|
||||
(define can-scroll-x? (or auto-scroll-x?
|
||||
hide-scroll-x?
|
||||
(and (memq 'hscroll style) #t)))
|
||||
(define can-scroll-y? (or auto-scroll-y?
|
||||
hide-scroll-y?
|
||||
(and (memq 'vscroll style) #t)))
|
||||
|
||||
(define scroll-x? can-scroll-x?)
|
||||
|
|
@ -454,15 +450,13 @@
|
|||
;; loop for fix-point on x and y scroll
|
||||
(let loop ([w w] [h h] [iters 0])
|
||||
(let ([want-scroll-x?
|
||||
(and (not hide-scroll-x?)
|
||||
(if auto-scroll-x?
|
||||
((car ms) . > . w)
|
||||
scroll-x?))]
|
||||
(if auto-scroll-x?
|
||||
((car ms) . > . w)
|
||||
scroll-x?)]
|
||||
[want-scroll-y?
|
||||
(and (not hide-scroll-y?)
|
||||
(if auto-scroll-y?
|
||||
((cadr ms) . > . h)
|
||||
scroll-y?))])
|
||||
(if auto-scroll-y?
|
||||
((cadr ms) . > . h)
|
||||
scroll-y?)])
|
||||
(if (and (eq? scroll-x? want-scroll-x?)
|
||||
(eq? scroll-y? want-scroll-y?))
|
||||
(values (if can-scroll-x?
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ has been moved out).
|
|||
"private/image-core-snipclass.rkt"
|
||||
"private/regmk.rkt"
|
||||
racket/snip
|
||||
(prefix-in : racket/base)
|
||||
(prefix-in cis: "cache-image-snip.rkt"))
|
||||
|
||||
|
||||
|
|
@ -455,11 +454,9 @@ has been moved out).
|
|||
(set-box/f! lspace 0)
|
||||
(set-box/f! rspace 0)))
|
||||
|
||||
(define/override (write f)
|
||||
(define bp (open-output-bytes))
|
||||
(:write (list shape bb pinhole) bp)
|
||||
(define bytes (get-output-bytes bp))
|
||||
(send f put (bytes-length bytes) bytes))
|
||||
(define/override (write f)
|
||||
(let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))])
|
||||
(send f put (bytes-length bytes) bytes)))
|
||||
|
||||
(super-new)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/pretty
|
||||
racket/gui/base
|
||||
racket/class
|
||||
(module interactive-value-port mzscheme
|
||||
(require mzlib/pretty
|
||||
mred
|
||||
mzlib/class
|
||||
"syntax-browser.rkt")
|
||||
(provide set-interactive-display-handler
|
||||
set-interactive-write-handler
|
||||
|
|
@ -11,7 +10,7 @@
|
|||
(define op (current-output-port))
|
||||
(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)])
|
||||
(port-display-handler
|
||||
port
|
||||
|
|
@ -19,19 +18,19 @@
|
|||
(cond
|
||||
[(string? val) (original-port-display-handler val port)]
|
||||
[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
|
||||
(λ (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
|
||||
(λ (val port)
|
||||
(do-printing pretty-print val port snip-handler))))
|
||||
(do-printing pretty-print val port))))
|
||||
|
||||
(define (use-number-snip? x)
|
||||
(and #f
|
||||
|
|
@ -42,7 +41,7 @@
|
|||
|
||||
(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
|
||||
[pretty-print-print-line (λ (line-number op old-line dest-columns)
|
||||
(when (and (not (equal? line-number 0))
|
||||
|
|
@ -71,19 +70,22 @@
|
|||
(cond
|
||||
[(not (port-writes-special? port)) #f]
|
||||
[(is-a? value snip%) 1]
|
||||
;[(use-number-snip? value) 1]
|
||||
[(syntax? value) 1]
|
||||
[else #f]))]
|
||||
[pretty-print-print-hook
|
||||
(λ (value display? port)
|
||||
(cond
|
||||
[(is-a? value snip%)
|
||||
(cond
|
||||
[snip-handler
|
||||
(snip-handler value port)]
|
||||
[else
|
||||
(write-special value port)])
|
||||
(write-special value port)
|
||||
1]
|
||||
#;
|
||||
[(use-number-snip? value)
|
||||
(write-special
|
||||
(number-snip:make-repeating-decimal-snip value #f)
|
||||
port)
|
||||
1]
|
||||
[(syntax? value)
|
||||
(write-special (render-syntax/snip value))]
|
||||
[else (void)]))])
|
||||
(pretty value port)))
|
||||
(pretty value port))))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ needed to really make this work:
|
|||
racket/class
|
||||
racket/gui/base
|
||||
racket/match
|
||||
(prefix-in - racket/base)
|
||||
"include-bitmap.rkt")
|
||||
|
||||
(define orig-output-port (current-output-port))
|
||||
|
|
@ -47,7 +46,7 @@ needed to really make this work:
|
|||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
(make-object syntax-snip%
|
||||
(unmarshall-syntax (-read (open-input-bytes (send stream get-bytes))))))
|
||||
(unmarshall-syntax (read (open-input-string (send stream get-bytes))))))
|
||||
(super-new)))
|
||||
|
||||
(define snip-class (new syntax-snipclass%))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang info
|
||||
|
||||
(define install-collection "installer.rkt")
|
||||
(define post-install-collection "installer.rkt")
|
||||
(define copy-man-pages '("gracket.1"))
|
||||
|
|
|
|||
|
|
@ -1,47 +1,32 @@
|
|||
#lang racket/base
|
||||
(require launcher
|
||||
racket/path
|
||||
racket/file
|
||||
setup/dirs)
|
||||
racket/file)
|
||||
|
||||
(provide installer)
|
||||
(provide post-installer)
|
||||
|
||||
(define (installer path coll user? no-main?)
|
||||
(unless no-main?
|
||||
(do-installer path coll user? #f)
|
||||
(when (and (not user?)
|
||||
(find-config-tethered-console-bin-dir))
|
||||
(do-installer path coll #f #t)))
|
||||
(when (find-addon-tethered-console-bin-dir)
|
||||
(do-installer path coll #t #t)))
|
||||
|
||||
(define (do-installer path collection user? tethered?)
|
||||
(define (post-installer path collection user?)
|
||||
(define variants (available-mred-variants))
|
||||
(define tether-mode (and tethered? (if user? 'addon 'config)))
|
||||
;; add a gracket-text executable that uses the -z flag (preferring a script)
|
||||
(for ([vs '((script-3m 3m) (script-cgc cgc))])
|
||||
(let ([v (findf (lambda (v) (memq v variants)) vs)])
|
||||
(when v
|
||||
(parameterize ([current-launcher-variant v])
|
||||
(make-mred-launcher
|
||||
#:tether-mode tether-mode
|
||||
'("-z")
|
||||
(prep-dir
|
||||
(mred-program-launcher-path "gracket-text" #:user? user? #:tethered? tethered?))
|
||||
`([subsystem . console]
|
||||
[single-instance? . #f]
|
||||
[relative? . ,(not (or user? tethered?))]))))))
|
||||
(mred-program-launcher-path "gracket-text" #:user? user?))
|
||||
`([subsystem . console] [single-instance? . #f]
|
||||
[relative? . ,(not user?)]))))))
|
||||
;; add a bin/gracket (in addition to lib/gracket)
|
||||
(for ([vs '((script-3m 3m) (script-cgc cgc))])
|
||||
(let ([v (findf (lambda (v) (memq v variants)) vs)])
|
||||
(when v
|
||||
(parameterize ([current-launcher-variant v])
|
||||
(make-mred-launcher #:tether-mode tether-mode
|
||||
null
|
||||
(make-mred-launcher null
|
||||
(prep-dir
|
||||
(mred-program-launcher-path "GRacket" #:user? user? #:tethered? tethered?))
|
||||
`([exe-name . "GRacket"]
|
||||
[relative? . ,(not (or user? tethered?))]
|
||||
(mred-program-launcher-path "GRacket" #:user? user?))
|
||||
'([exe-name . "GRacket"] [relative? . ,(not user?)]
|
||||
[exe-is-gracket . #t])))))))
|
||||
|
||||
(define (prep-dir p)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -128,6 +128,8 @@
|
|||
(queue-callback
|
||||
(λ ()
|
||||
(send (test:get-active-top-level-window) close)))
|
||||
(preferences:set 'framework:file-dialogs 'std) ;; this is not gooD!!!!
|
||||
(error 'ack "need to figure out how to use the hash-based prefs...?")
|
||||
editor-contents))
|
||||
test-file-contents
|
||||
name))
|
||||
|
|
@ -136,19 +138,9 @@
|
|||
(test-open "frame:searchable open" frame:searchable%)
|
||||
(test-open "frame:text open" frame:text%))
|
||||
|
||||
(let ([pref-ht (make-hash)])
|
||||
(parameterize ([test:use-focus-table #t]
|
||||
[preferences:low-level-get-preference
|
||||
(λ (sym [fail (λ () #f)])
|
||||
(hash-ref pref-ht sym fail))]
|
||||
[preferences:low-level-put-preferences
|
||||
(λ (syms vals)
|
||||
(for ([sym (in-list syms)]
|
||||
[val (in-list vals)])
|
||||
(hash-set! pref-ht sym val)))])
|
||||
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
|
||||
(send dummy show #t)
|
||||
(creation-tests)
|
||||
(open-tests)
|
||||
(send dummy show #f)))
|
||||
|
||||
(parameterize ([test:use-focus-table #t])
|
||||
(define dummy (make-object frame:basic% "dummy to keep from quitting"))
|
||||
(send dummy show #t)
|
||||
(creation-tests)
|
||||
(open-tests)
|
||||
(send dummy show #f))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(module test racket/base)
|
||||
|
||||
(define windows-menu-prefix
|
||||
(let ([basics (list "Bring Frame to Front…" "Most Recent Window"
|
||||
(let ([basics (list "Bring Frame to Front..." "Most Recent Window"
|
||||
#f)])
|
||||
(if (eq? (system-type) 'macosx)
|
||||
(list* "Minimize" "Zoom" basics)
|
||||
|
|
|
|||
|
|
@ -89,26 +89,6 @@
|
|||
(sort (hash-map (send k get-map-function-table) list)
|
||||
string<?
|
||||
#:key (lambda (x) (format "~s" x)))))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/longer-name
|
||||
(lambda (x)
|
||||
(equal? x '((|c:x;r| "swap if branches"))))
|
||||
(lambda ()
|
||||
(queue-sexp-to-mred
|
||||
'(let ()
|
||||
(define k0 (new keymap:aug-keymap%))
|
||||
(define k1 (new keymap:aug-keymap%))
|
||||
(define k2 (new keymap:aug-keymap%))
|
||||
(send k1 add-function "rectangle" void)
|
||||
(send k1 map-function "c:x;r;a" "rectangle")
|
||||
(send k2 add-function "swap if branches" void)
|
||||
(send k2 map-function "c:x;r" "swap if branches")
|
||||
(send k0 chain-to-keymap k1 #t)
|
||||
(send k0 chain-to-keymap k2 #t)
|
||||
(sort (hash-map (send k0 get-map-function-table) list)
|
||||
string<?
|
||||
#:key (lambda (x) (format "~s" x)))))))
|
||||
|
||||
(define (test-canonicalize name str1 str2)
|
||||
(test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
(test
|
||||
'number-snip-convert-text
|
||||
(λ (x) (or (equal? "1/2" x) (equal? "0.5" x)))
|
||||
(λ (x) (equal? "1/2" x))
|
||||
(lambda ()
|
||||
(queue-sexp-to-mred
|
||||
`((dynamic-require 'file/convertible 'convert)
|
||||
|
|
|
|||
|
|
@ -175,10 +175,6 @@
|
|||
"(#:x\n 1)")
|
||||
(test-indentation "(#:x 0\n1)"
|
||||
"(#:x 0\n 1)")
|
||||
(test-indentation "(a b c d\n---)"
|
||||
"(a b c d\n ---)")
|
||||
(test-indentation "[---- \"β\"\na"
|
||||
"[---- \"β\"\n a")
|
||||
|
||||
|
||||
(define (test-magic-square-bracket which before after)
|
||||
|
|
|
|||
|
|
@ -67,35 +67,35 @@
|
|||
(send t set-searching-state "aba" #t #f)
|
||||
(send t set-position 0 0)))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((4 . 3) normal-search-color)))
|
||||
((4 . 7) normal-search-color)))
|
||||
(test-search (list '(begin (send t insert "aba aba")
|
||||
(send t set-searching-state "aba" #t #f))
|
||||
'(send t set-position 0 0))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((4 . 3) normal-search-color)))
|
||||
((4 . 7) normal-search-color)))
|
||||
|
||||
|
||||
(test-search (list '(begin (send t insert "abaaba")
|
||||
(send t set-searching-state "aba" #t #f)
|
||||
(send t set-position 0 0)))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((3 . 3) normal-search-color)))
|
||||
((3 . 6) normal-search-color)))
|
||||
(test-search (list '(begin (send t insert "abaaba")
|
||||
(send t set-searching-state "aba" #t #f))
|
||||
'(send t set-position 0 0))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((3 . 3) normal-search-color)))
|
||||
((3 . 6) normal-search-color)))
|
||||
|
||||
(test-search (list '(begin (send t insert "abababa")
|
||||
(send t set-searching-state "aba" #t #f)
|
||||
(send t set-position 0 0)))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((4 . 3) normal-search-color)))
|
||||
((4 . 7) normal-search-color)))
|
||||
(test-search (list '(begin (send t insert "abababa")
|
||||
(send t set-searching-state "aba" #t #f))
|
||||
'(send t set-position 0 0))
|
||||
`(((0 . 3) normal-search-color)
|
||||
((4 . 3) normal-search-color)))
|
||||
((4 . 7) normal-search-color)))
|
||||
|
||||
(test-search (list '(begin (send t insert "Aba")
|
||||
(send t set-searching-state "aba" #t #f)
|
||||
|
|
@ -131,25 +131,25 @@
|
|||
(send t set-searching-state "aba" #f #t)
|
||||
(send t set-position 0 0)))
|
||||
`(((0 . 3) dark-search-color)
|
||||
((4 . 3) light-search-color)))
|
||||
((4 . 7) light-search-color)))
|
||||
(test-search (list '(begin (send t insert "abababa")
|
||||
(send t set-searching-state "aba" #f #t))
|
||||
'(send t set-position 0 0))
|
||||
`(((0 . 3) dark-search-color)
|
||||
((4 . 3) light-search-color)))
|
||||
((4 . 7) light-search-color)))
|
||||
|
||||
(test-search (list '(begin (send t insert "aba aba aba")
|
||||
(send t set-searching-state "aba" #f #t)
|
||||
(send t set-position 1 1)))
|
||||
`(((0 . 3) light-search-color)
|
||||
((4 . 3) dark-search-color)
|
||||
((8 . 3) light-search-color)))
|
||||
((4 . 7) dark-search-color)
|
||||
((8 . 11) light-search-color)))
|
||||
(test-search (list '(begin (send t insert "aba aba aba")
|
||||
(send t set-searching-state "aba" #f #t))
|
||||
'(send t set-position 1 1))
|
||||
`(((0 . 3) light-search-color)
|
||||
((4 . 3) dark-search-color)
|
||||
((8 . 3) light-search-color)))
|
||||
((4 . 7) dark-search-color)
|
||||
((8 . 11) light-search-color)))
|
||||
|
||||
(test-search (list '(begin (send t insert "aba")
|
||||
(send t set-searching-state "aba" #f #t))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
load-framework-automatically
|
||||
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
|
||||
wait-for-frame
|
||||
|
||||
|
|
@ -52,7 +52,7 @@
|
|||
|
||||
(module local-namespace racket/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
|
||||
eof-result?
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
|
|
@ -76,13 +76,6 @@
|
|||
(eval sexp)))))
|
||||
(channel-get c))
|
||||
|
||||
(define (send-sexp-to-mred/separate-thread sexp)
|
||||
(unless ns?
|
||||
(namespace-require 'framework)
|
||||
(namespace-require 'racket/gui/base)
|
||||
(set! ns? #t))
|
||||
(eval sexp))
|
||||
|
||||
(define queue-sexp-to-mred send-sexp-to-mred)
|
||||
|
||||
(define (eof-result? x)
|
||||
|
|
@ -127,7 +120,7 @@
|
|||
"debug.rkt"
|
||||
racket/tcp
|
||||
racket/pretty)
|
||||
(provide send-sexp-to-mred send-sexp-to-mred/separate-thread
|
||||
(provide send-sexp-to-mred
|
||||
queue-sexp-to-mred
|
||||
eof-result?
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
|
|
@ -279,9 +272,6 @@
|
|||
[(normal)
|
||||
(eval (list-ref answer 1))]))))))
|
||||
|
||||
(define (send-sexp-to-mred/separate-thread sexp)
|
||||
(send-sexp-to-mred sexp))
|
||||
|
||||
(define queue-sexp-to-mred
|
||||
(lambda (sexp)
|
||||
(send-sexp-to-mred
|
||||
|
|
@ -329,7 +319,7 @@
|
|||
(define n (if use-local? l:n r:n))
|
||||
(choose ns ...))))]))
|
||||
|
||||
(choose send-sexp-to-mred send-sexp-to-mred/separate-thread
|
||||
(choose send-sexp-to-mred
|
||||
queue-sexp-to-mred
|
||||
eof-result?
|
||||
shutdown-listener shutdown-mred mred-running?
|
||||
|
|
|
|||
|
|
@ -355,98 +355,6 @@
|
|||
(send t insert (new snip%) (send t last-position))
|
||||
(send t all-string-snips?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; searching
|
||||
;;
|
||||
|
||||
(define (search-test name setup-code expected-answer)
|
||||
(test
|
||||
name
|
||||
(λ (x) (equal? x expected-answer))
|
||||
(λ ()
|
||||
(send-sexp-to-mred/separate-thread
|
||||
`(let ()
|
||||
(define answer (make-channel))
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(define t (new text:searching%))
|
||||
,setup-code
|
||||
(let loop ()
|
||||
(cond
|
||||
[(send t search-updates-pending?)
|
||||
(queue-callback (λ () (loop)) #f)]
|
||||
[else
|
||||
(define-values (before total) (send t get-search-hit-count))
|
||||
(channel-put answer (list before total))]))))
|
||||
(channel-get answer))))))
|
||||
|
||||
(search-test
|
||||
'search.1
|
||||
`(begin (send t insert "abc")
|
||||
(send t set-position 0 0)
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 0 1))
|
||||
|
||||
(search-test
|
||||
'search.2
|
||||
`(begin (send t insert "abc")
|
||||
(send t set-position 3 3)
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 1 1))
|
||||
|
||||
(search-test
|
||||
'search.3
|
||||
`(begin (send t insert "abc")
|
||||
(define t2 (new text%))
|
||||
(send t2 insert "abc")
|
||||
(send t insert (new editor-snip% [editor t2]))
|
||||
(send t2 insert "abc")
|
||||
(send t set-position 0 0)
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 0 3))
|
||||
|
||||
(search-test
|
||||
'search.4
|
||||
`(begin (send t insert "abc")
|
||||
(define t2 (new text%))
|
||||
(send t2 insert "abc")
|
||||
(send t insert (new editor-snip% [editor t2]))
|
||||
(send t insert "abc")
|
||||
(send t set-position (send t last-position) (send t last-position))
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 3 3))
|
||||
|
||||
(search-test
|
||||
'search.5
|
||||
`(begin (send t insert "abc")
|
||||
(define t2 (new text%))
|
||||
(send t2 insert "abc")
|
||||
(define t3 (new text%))
|
||||
(send t3 insert "abc")
|
||||
(send t2 insert (new editor-snip% [editor t3]))
|
||||
(send t2 insert "abc")
|
||||
(send t insert (new editor-snip% [editor t2]))
|
||||
(send t insert "abc")
|
||||
(send t set-position (send t last-position) (send t last-position))
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 5 5))
|
||||
|
||||
(search-test
|
||||
'search.6
|
||||
`(begin (send t insert "abc")
|
||||
(define t2 (new text%))
|
||||
(send t2 insert "abc")
|
||||
(define t3 (new text%))
|
||||
(send t3 insert "abc")
|
||||
(send t2 insert (new editor-snip% [editor t3]))
|
||||
(send t2 insert "abc")
|
||||
(send t insert (new editor-snip% [editor t2]))
|
||||
(send t insert "abc")
|
||||
(send t set-position 0 0)
|
||||
(send t set-searching-state "b" #f #f))
|
||||
(list 0 5))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; print-to-dc
|
||||
|
|
@ -712,126 +620,3 @@
|
|||
(flush-output port))
|
||||
(semaphore-wait clear-output-done)
|
||||
(send text get-text))))))
|
||||
|
||||
(test
|
||||
'text:ports%.undo-does-not-remove-port-colors
|
||||
(λ (x+y)
|
||||
(equal? (list-ref x+y 0)
|
||||
(list-ref x+y 1)))
|
||||
(λ ()
|
||||
(queue-sexp-to-mred
|
||||
`(let ()
|
||||
(define t (new (text:ports-mixin
|
||||
(editor:standard-style-list-mixin
|
||||
text:wide-snip%))))
|
||||
|
||||
(send t set-max-undo-history 'forever)
|
||||
(define last-undo? #f)
|
||||
(send t add-undo (λ () (set! last-undo? #t)))
|
||||
|
||||
(define vp (send t get-value-port))
|
||||
(define op (send t get-out-port))
|
||||
|
||||
(display "1" vp)
|
||||
(display "2" op)
|
||||
(flush-output vp)
|
||||
(flush-output op)
|
||||
|
||||
(define (to-vec c) (vector (send c red) (send c green) (send c blue)))
|
||||
|
||||
(define (get-colors)
|
||||
(let loop ([s (send t find-first-snip)])
|
||||
(cond
|
||||
[s (cons (list (send s get-text 0 (send s get-count))
|
||||
(to-vec (send (send s get-style) get-foreground)))
|
||||
(loop (send s next)))]
|
||||
[else '()])))
|
||||
|
||||
(define before (get-colors))
|
||||
(let loop ()
|
||||
(unless last-undo?
|
||||
(send t undo)
|
||||
(loop)))
|
||||
(define after (get-colors))
|
||||
(list before after)))))
|
||||
|
||||
(define (test-ascii-art-enlarge-boxes-mixin name before position overwrite? chars after)
|
||||
(test
|
||||
name
|
||||
(λ (got) (equal? got after))
|
||||
(λ ()
|
||||
(queue-sexp-to-mred
|
||||
`(let ([t (new (text:ascii-art-enlarge-boxes-mixin text%))])
|
||||
(send t set-ascii-art-enlarge #t)
|
||||
(define f (new frame% [label ""]))
|
||||
(define ec (new editor-canvas% [parent f] [editor t]))
|
||||
(send t insert
|
||||
,before)
|
||||
(send t set-position ,position ,position)
|
||||
,@(if overwrite? (list '(send t set-overwrite-mode #t)) '())
|
||||
,@(for/list ([char (in-list chars)])
|
||||
`(send ec on-char (new key-event% [key-code ,char])))
|
||||
(send t get-text))))))
|
||||
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.1
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #t '(#\a)
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║a║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.2
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #t'(#\a #\b)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ab║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.3
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
7 #f '(#\a)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║a ║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
||||
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.4
|
||||
(string-append
|
||||
"╔═╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ ║ ║\n"
|
||||
"╠═╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚═╩═╝\n")
|
||||
14 #f '(#\f)
|
||||
(string-append
|
||||
"╔══╦═╗\n"
|
||||
"║ ║ ║\n"
|
||||
"║ f║ ║\n"
|
||||
"╠══╬═╣\n"
|
||||
"║ ║ ║\n"
|
||||
"╚══╩═╝\n"))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -927,18 +927,6 @@
|
|||
#"")
|
||||
(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
|
||||
|
||||
|
|
@ -1212,16 +1200,6 @@
|
|||
(expect (send km handle-key-event 'obj kevt) #t)
|
||||
(expect hit #\t)
|
||||
|
||||
(let ()
|
||||
(define k (new keymap%))
|
||||
(send k add-function "swap if branches" void)
|
||||
(send k map-function "c:x;r" "swap if branches")
|
||||
(send k add-function "rectangle" void)
|
||||
(expect (regexp-match? (regexp-quote "map-function in keymap%: \"r\" is already mapped as a non-prefix key")
|
||||
(with-handlers ([exn:fail? exn-message])
|
||||
(send k map-function "c:x;r;a" "rectangle")))
|
||||
#t))
|
||||
|
||||
;; Chained keymap non-prefixed overrides prefixed
|
||||
(send km2 add-function "letter-d" (lambda (obj evt) (set! hit #\d)))
|
||||
(send km2 map-function "d" "letter-d")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user