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

improve the interactivity of DrRacket's search

Browse Source 
Changes the implementation of highlight-range so that it
only recomputes all of the new locations from the positions
when on-reflow is called (otherwise only computing the
relevant ones) and make the on-reflow callback chop itself
up, in case there are lots of highlighted ranges to avoid
tying up the event loop.

Changes searching so that it doesn't neccessarily compute
the entire search results in a single event callback
(but also make it start the computation more aggressively)

Overall, this changes the strategy from one that, for any potentially
long-running callback, just tried to push it off into the future, into
a strategy that tries to avoid long-running callbacks by breaking the
work up into chunks, but starting the first chunk immediately (in a
low-priority callback).

Also, misc other changes to make this work better and generally clean
things up.
This commit is contained in:
Robby Findler 2012-11-22 09:28:11 -06:00
parent 0264d3d5ad
commit 5197649cb7
8 changed files with 1217 additions and 959 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
collects/framework/private/coroutine.rkt Normal file
View File

@ -0,0 +1,120 @@
#lang racket/base
(require racket/contract)
(provide coroutine)
(provide
(contract-out
[coroutine-run (-> coroutine? any/c boolean?)]
[coroutine-runnable? (-> coroutine? boolean?)]
[coroutine-value (-> coroutine? any/c)]))
(define-syntax-rule
(coroutine pause-id first-id exp1 exp2 ...)
(coroutine/proc (λ (pause-id first-id) exp1 exp2 ...)))
(struct coroutine ([run-proc #:mutable] [val #:mutable] tag)
#:omit-define-syntaxes
#:extra-constructor-name
make-coroutine)
(define (coroutine/proc cproc)
(define tag (make-continuation-prompt-tag 'coroutine))
(define (pauser)
(call-with-composable-continuation
(λ (k) (abort-current-continuation tag k))
tag))
(make-coroutine (λ (first-val) (values (cproc pauser first-val) #t))
#f
tag))
(define (coroutine-run a-coroutine val)
(cond
[(coroutine-run-proc a-coroutine)
=>
(λ (proc)
(define-values (res done?)
(call-with-continuation-prompt
(λ () (proc val))
(coroutine-tag a-coroutine)
(λ (k)
(set-coroutine-run-proc!
a-coroutine
(λ (next-val)
(k next-val)))
(values #f #f))))
(cond
[done?
(set-coroutine-run-proc! a-coroutine #f)
(set-coroutine-val! a-coroutine res)
#t]
[else #f]))]
[else
(error 'coroutine-run "coroutine already terminated")]))
(define (coroutine-runnable? a-coroutine)
(and (coroutine-run-proc a-coroutine)
#t))
(define (coroutine-value a-coroutine)
(when (coroutine-runnable? a-coroutine)
(error 'coroutine-value "coroutine not yet finished"))
(coroutine-val a-coroutine))
(module+ test
(require rackunit)
(define c
(coroutine
pause
first
(begin
(printf "first ~s\n" first)
(let loop ([i 5])
(printf "i ~a\n" i)
(when (zero? (modulo i 3))
(printf ">> ~a\n" (pause)))
(cond
[(zero? i) '()]
[else
(cons i (loop (- i 1)))])))))
(define (with-stdout th)
(define sp (open-output-string))
(list (parameterize ([current-output-port sp])
(th))
(get-output-string sp)))
(check-equal? (with-stdout (λ () (coroutine-run c 123)))
(list #f "first 123\ni 5\ni 4\ni 3\n"))
(check-equal? (with-stdout (λ () (coroutine-run c 456)))
(list #f ">> 456\ni 2\ni 1\ni 0\n"))
(check-equal? (with-stdout (λ () (coroutine-run c 789)))
(list #t ">> 789\n"))
(check-equal? (coroutine-value c)
'(5 4 3 2 1))
(define c2
(coroutine
pause first
(define x first)
(define (try-it)
(define new-x (pause))
(printf "~a => ~a\n" x new-x)
(set! x new-x))
(try-it)
(try-it)
x))
(check-equal? (with-stdout (λ () (coroutine-run c2 0)))
(list #f ""))
(check-equal? (with-stdout (λ () (coroutine-run c2 1)))
(list #f "0 => 1\n"))
(check-equal? (with-stdout (λ () (coroutine-run c2 2)))
(list #t "1 => 2\n"))
(check-equal? (coroutine-value c2)
2))

3
collects/framework/private/editor.rkt
View File

@ -40,7 +40,8 @@
close close
get-filename/untitled-name get-filename/untitled-name
get-pos/text)) get-pos/text
get-pos/text-dc-location))
(define basic-mixin (define basic-mixin
(mixin (editor<%>) (basic<%>) (mixin (editor<%>) (basic<%>)

322
collects/framework/private/frame.rkt
View File

@ -1919,28 +1919,18 @@
(send text-to-search set-search-anchor (send text-to-search get-start-position))))))) (send text-to-search set-search-anchor (send text-to-search get-start-position)))))))
(super on-focus on?)) (super on-focus on?))
(define timer #f)
(define/private (update-search/trigger-jump/later)
(run-after-edit-sequence
(λ ()
(unless timer
(set! timer (new timer%
[notify-callback
(λ ()
(update-searching-str)
(trigger-jump))])))
(send timer stop)
(send timer start 150 #t))
'framework:search-frame:changed-search-string))
(define/augment (after-insert x y) (define/augment (after-insert x y)
(update-search/trigger-jump/later) (update-searching-str/trigger-jump)
(inner (void) after-insert x y)) (inner (void) after-insert x y))
(define/augment (after-delete x y) (define/augment (after-delete x y)
(update-search/trigger-jump/later) (update-searching-str/trigger-jump)
(inner (void) after-delete x y)) (inner (void) after-delete x y))
(define/private (update-searching-str/trigger-jump)
(define/private (trigger-jump) (let ([tlw (get-top-level-window)])
(when tlw
(send tlw search-string-changed)))
;; trigger-jump
(when (preferences:get 'framework:anchored-search) (when (preferences:get 'framework:anchored-search)
(let ([frame (get-top-level-window)]) (let ([frame (get-top-level-window)])
(when frame (when frame
@ -1953,6 +1943,7 @@
(send text-to-search set-position anchor-pos anchor-pos)] (send text-to-search set-position anchor-pos anchor-pos)]
[else [else
(search 'forward #t #t #f anchor-pos)]))))))))) (search 'forward #t #t #f anchor-pos)])))))))))
(define/private (get-searching-text) (define/private (get-searching-text)
(let ([frame (get-top-level-window)]) (let ([frame (get-top-level-window)])
@ -2062,12 +2053,6 @@
(not-found found-edit #f))] (not-found found-edit #f))]
[else [else
(found found-edit first-pos)]))))))) (found found-edit first-pos)])))))))
(define callback-queued? #f)
(define/private (update-searching-str)
(let ([tlw (get-top-level-window)])
(when tlw
(send tlw search-string-changed))))
(define/override (on-paint before dc left top right bottom dx dy draw-caret?) (define/override (on-paint before dc left top right bottom dx dy draw-caret?)
(super on-paint before dc left top right bottom dx dy draw-caret?) (super on-paint before dc left top right bottom dx dy draw-caret?)
@ -2241,7 +2226,7 @@
(string-constant hide-replace-menu-item) (string-constant hide-replace-menu-item)
(string-constant show-replace-menu-item)))) (string-constant show-replace-menu-item))))
(define/override (edit-menu:replace-callback a b) (search-replace)) (define/override (edit-menu:replace-callback a b) (search-replace) #t)
(define/override (edit-menu:create-replace?) #t) (define/override (edit-menu:create-replace?) #t)
(define/override (edit-menu:replace-on-demand item) (define/override (edit-menu:replace-on-demand item)
(send item enable (and (not hidden?) replace-visible?))) (send item enable (and (not hidden?) replace-visible?)))
@ -2278,12 +2263,13 @@
(unless hidden? (unless hidden?
(when find-edit (when find-edit
(when old (when old
(send old set-searching-state #f #f #f) (send old set-searching-state #f #f #f #f)
(send old set-search-anchor #f)) (send old set-search-anchor #f))
(when new (when new
(send new set-search-anchor (send new get-start-position)) (send new set-search-anchor (send new get-start-position))
(search-parameters-changed))))))) (search-parameters-changed)))))))
;; called by the text-to-search when it finishes the search
(define/public-final (search-hits-changed) (define/public-final (search-hits-changed)
(when find-edit (when find-edit
(when text-to-search (when text-to-search
@ -2294,15 +2280,13 @@
(send find-canvas set-red is-red?)))))) (send find-canvas set-red is-red?))))))
(define/public-final (search-string-changed) (search-parameters-changed)) (define/public-final (search-string-changed) (search-parameters-changed))
(define/public-final (search-text-changed) (search-parameters-changed))
(define/private (search-parameters-changed) (define/private (search-parameters-changed)
(let ([str (send find-edit get-text)]) (let ([str (send find-edit get-text)])
(send text-to-search set-searching-state (send text-to-search set-searching-state
(if (equal? str "") #f str) (if (equal? str "") #f str)
case-sensitive-search? case-sensitive-search?
(and replace-visible? (send text-to-search get-start-position)))) replace-visible?
(search-hits-changed)) #t)))
(define/public (search-hidden?) hidden?) (define/public (search-hidden?) hidden?)
@ -2310,7 +2294,7 @@
(set! hidden? #t) (set! hidden? #t)
(when search-gui-built? (when search-gui-built?
(when text-to-search (when text-to-search
(send text-to-search set-searching-state #f #f #f)) (send text-to-search set-searching-state #f #f #f #f))
(send super-root change-children (send super-root change-children
(λ (l) (λ (l)
(remove search/replace-panel l))) (remove search/replace-panel l)))
@ -2377,28 +2361,8 @@
(send text-to-search set-position replacee-end replacee-end) (send text-to-search set-position replacee-end replacee-end)
(send text-to-search delete replacee-start replacee-end) (send text-to-search delete replacee-start replacee-end)
(copy-over replace-edit 0 (send replace-edit last-position) text-to-search replacee-start) (copy-over replace-edit 0 (send replace-edit last-position) text-to-search replacee-start)
(let ([str (send find-edit get-text)]) (search 'forward)
(send text-to-search set-searching-state (send text-to-search end-edit-sequence)))))))
(if (equal? str "") #f str)
case-sensitive-search?
;; the start position will have moved (but to the right place),
;; if a relacement has happened.
(send text-to-search get-start-position))
;; set the selection to the next place to replace
(let-values ([(before-caret-hits hits) (send text-to-search get-search-hit-count)])
(unless (zero? hits)
(unless (send text-to-search get-replace-search-hit)
(send text-to-search set-position 0 0))
(let ([next-start (send text-to-search get-replace-search-hit)])
(when next-start ;; this shouldn't ever matter ...?
(send text-to-search set-position next-start (+ next-start (send find-edit last-position)))))))
(search-hits-changed))
(send text-to-search end-edit-sequence)
#t))))))
(define/private (copy-over src-txt src-start src-end dest-txt dest-pos) (define/private (copy-over src-txt src-start src-end dest-txt dest-pos)
(send src-txt split-snip src-start) (send src-txt split-snip src-start)
@ -2491,135 +2455,133 @@
(unless search-gui-built? (unless search-gui-built?
(set! search-gui-built? #t) (set! search-gui-built? #t)
(begin-container-sequence) (begin-container-sequence)
(let () (set! find-edit (new find-text%))
(define _-2 (set! find-edit (new find-text%))) (set! replace-edit (new replace-text%))
(define _-1 (set! replace-edit (new replace-text%))) (set! search/replace-panel (new horizontal-panel%
(define _0 (set! search/replace-panel (new horizontal-panel% [parent super-root]
[parent super-root] [stretchable-height #f]))
[stretchable-height #f]))) (define search-panel
(define search-panel (new horizontal-panel%
(new horizontal-panel% [parent search/replace-panel]
[parent search/replace-panel] [stretchable-height #f]))
[stretchable-height #f])) (define replace-panel
(define replace-panel (new horizontal-panel%
(new horizontal-panel% [parent search/replace-panel]
[parent search/replace-panel] [stretchable-height #f]))
[stretchable-height #f])) (set! find-canvas (new searchable-canvas%
(define _1 (set! find-canvas (new searchable-canvas% [style '(hide-hscroll hide-vscroll)]
[style '(hide-hscroll hide-vscroll)] [vertical-inset 2]
[vertical-inset 2] [parent search-panel]
[parent search-panel] [editor find-edit]
[editor find-edit] [line-count 1]
[line-count 1] [stretchable-height #f]
[stretchable-height #f] [stretchable-width #t]))
[stretchable-width #t]))) (set! replace-canvas (new searchable-canvas%
[style '(hide-hscroll hide-vscroll)]
(define _3 (set! replace-canvas (new searchable-canvas% [vertical-inset 2]
[style '(hide-hscroll hide-vscroll)] [parent replace-panel]
[vertical-inset 2] [editor replace-edit]
[parent replace-panel] [line-count 1]
[editor replace-edit]
[line-count 1]
[stretchable-height #f]
[stretchable-width #t])))
(define search-button (new button%
[label (string-constant search-next)]
[vert-margin 0]
[parent search-panel]
[callback (λ (x y) (search 'forward))]
[font small-control-font]))
(define search-prev-button (new button%
[label (string-constant search-previous)]
[vert-margin 0]
[parent search-panel]
[callback (λ (x y) (search 'backward))]
[font small-control-font]))
(define hits-panel (new vertical-panel%
[parent search-panel]
[alignment '(left center)]
[stretchable-height #f] [stretchable-height #f]
[stretchable-width #f])) [stretchable-width #t]))
(define num-msg (new message% (define search-button (new button%
[label "0"] [label (string-constant search-next)]
[vert-margin 0]
[auto-resize #t]
[font tiny-control-font]
[parent hits-panel]))
(define matches-msg (new message%
[label (string-constant search-matches)]
[vert-margin 0] [vert-margin 0]
[font tiny-control-font] [parent search-panel]
[parent hits-panel])) [callback (λ (x y) (search 'forward))]
[font small-control-font]))
(define _6 (set! update-matches (define search-prev-button (new button%
(λ (before-caret-m m) [label (string-constant search-previous)]
(cond [vert-margin 0]
[(zero? m) [parent search-panel]
(send num-msg set-label "0")] [callback (λ (x y) (search 'backward))]
[else [font small-control-font]))
(let ([number (number->str/comma m)]
[bc-number (number->str/comma before-caret-m)]) (define hits-panel (new vertical-panel%
(send num-msg set-label (format "~a/~a" bc-number number)))]) [parent search-panel]
(send matches-msg set-label (if (= m 1) [alignment '(left center)]
(string-constant search-match) [stretchable-height #f]
(string-constant search-matches)))))) [stretchable-width #f]))
(define replace-button (define num-msg (new message%
(new button% [label "0"]
[label (string-constant search-replace)] [vert-margin 0]
[vert-margin 0] [auto-resize #t]
[parent replace-panel] [font tiny-control-font]
[font small-control-font] [parent hits-panel]))
[callback (λ (x y) (search-replace))])) (define matches-msg (new message%
(define skip-button [label (string-constant search-matches)]
(new button% [vert-margin 0]
[label (string-constant search-skip)] [font tiny-control-font]
[vert-margin 0] [parent hits-panel]))
[parent replace-panel]
[font small-control-font] (define _6 (set! update-matches
[callback (λ (x y) (search 'forward))])) (λ (before-caret-m m)
(cond
(define show-replace-button [(zero? m)
(new button% (send num-msg set-label "0")]
[label (string-constant search-show-replace)] [else
[font small-control-font] (let ([number (number->str/comma m)]
[callback (λ (a b) (set-replace-visible? #t))] [bc-number (number->str/comma before-caret-m)])
[parent replace-panel])) (send num-msg set-label (format "~a/~a" bc-number number)))])
(define hide-replace-button (send matches-msg set-label (if (= m 1)
(new button% (string-constant search-match)
[label (string-constant search-hide-replace)] (string-constant search-matches))))))
[font small-control-font]
[callback (λ (a b) (set-replace-visible? #f))] (define replace-button
[parent replace-panel])) (new button%
[label (string-constant search-replace)]
(set! show/hide-replace [vert-margin 0]
(λ () [parent replace-panel]
(send replace-panel begin-container-sequence) [font small-control-font]
(cond [callback (λ (x y) (search-replace))]))
[replace-visible? (define skip-button
(send replace-panel change-children (λ (l) all-replace-children)) (new button%
(send replace-panel stretchable-width #t)] [label (string-constant search-skip)]
[else [vert-margin 0]
(send replace-panel change-children (λ (l) (list show-replace-button))) [parent replace-panel]
(send replace-panel stretchable-width #f)]) [font small-control-font]
(send replace-panel end-container-sequence))) [callback (λ (x y) (search 'forward))]))
(define all-replace-children (define show-replace-button
(list replace-canvas (new button%
replace-button [label (string-constant search-show-replace)]
skip-button [font small-control-font]
hide-replace-button)) [callback (λ (a b) (set-replace-visible? #t))]
[parent replace-panel]))
(define hide-button (define hide-replace-button
(new close-icon% (new button%
[callback (λ () (hide-search))] [label (string-constant search-hide-replace)]
[vertical-pad 0] [font small-control-font]
[parent search/replace-panel])) [callback (λ (a b) (set-replace-visible? #f))]
[parent replace-panel]))
(show/hide-replace))
(set! show/hide-replace
(λ ()
(send replace-panel begin-container-sequence)
(cond
[replace-visible?
(send replace-panel change-children (λ (l) all-replace-children))
(send replace-panel stretchable-width #t)]
[else
(send replace-panel change-children (λ (l) (list show-replace-button)))
(send replace-panel stretchable-width #f)])
(send replace-panel end-container-sequence)))
(define all-replace-children
(list replace-canvas
replace-button
skip-button
hide-replace-button))
(define hide-button
(new close-icon%
[callback (λ () (hide-search))]
[vertical-pad 0]
[parent search/replace-panel]))
(show/hide-replace)
(end-container-sequence))) (end-container-sequence)))
(super-new))) (super-new)))

1434
collects/framework/private/text.rkt
View File

File diff suppressed because it is too large Load Diff

57
collects/scribblings/framework/text.scrbl
View File

@ -11,8 +11,8 @@
(end exact-nonnegative-integer?) (end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(priority (symbols 'high 'low) 'low) (priority (or/c 'high 'low) 'low)
(style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) (style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
(-> void?)))]{ (-> void?)))]{
This function highlights a region of text in the buffer. This function highlights a region of text in the buffer.
@ -46,16 +46,33 @@
} }
@defmethod[(unhighlight-range @defmethod[(unhighlight-range
(start exact-nonnegative-integer?) (start exact-nonnegative-integer?)
(end exact-nonnegative-integer?) (end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) (style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
void?]{ void?]{
This method removes the highlight from a region of text in the buffer. This method removes the highlight from a region of text in the buffer.
The region must match up to a region specified from an earlier call to The region must match up to a region specified from an earlier call to
@method[text:basic<%> highlight-range]. @method[text:basic<%> highlight-range].
This method does a linear scan over all of the regions currently set.
If you expect to call this method many times (when there are many
ranges set)
consider instead calling @method[text:basic<%> unhighlight-ranges].
}
@defmethod[(unhighlight-ranges
[pred? (-> exact-nonnegative-integer?
exact-nonnegative-integer?
(is-a?/c color%)
boolean?
(or/c 'rectangle 'ellipse 'hollow-ellipse)
boolean?)])
void?]{
This method removes the highlight from regions in the buffer as
selected by @racket[pred?].
} }
@defmethod*[(((get-highlighted-ranges) (listof text:range?)))]{ @defmethod*[(((get-highlighted-ranges) (listof text:range?)))]{
@ -353,11 +370,12 @@
@defmethod[(set-searching-state [str (or/c false/c string?)] @defmethod[(set-searching-state [str (or/c false/c string?)]
[cs? boolean?] [cs? boolean?]
[replace-start (or/c false/c number?)]) [replace-start (or/c false/c number?)]
[notify-frame? boolean?])
void?]{ void?]{
If @racket[str] is not @racket[#f], then this method highlights every If @racket[str] is not @racket[#f], then this method initiates a search for
occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f], every occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f],
then it clears all of the highlighting in the buffer. then it clears all of the search highlighting in the buffer.
If @racket[cs?] is @racket[#f], the search is case-insensitive, and otherwise If @racket[cs?] is @racket[#f], the search is case-insensitive, and otherwise
it is case-sensitive. it is case-sensitive.
@ -365,6 +383,13 @@
If the @racket[replace-start] argument is @racket[#f], then the search is not If the @racket[replace-start] argument is @racket[#f], then the search is not
in replacement mode. If it is a number, then the first search hit after that in replacement mode. If it is a number, then the first search hit after that
position in the editor is where the next replacement will take place. position in the editor is where the next replacement will take place.
The search does not complete before @method[text:searching<%> set-searching-state]
returns. Accordingly, @method[text:searching<%> get-search-hit-count] may
have out-of-date results for a while, until the search process is finished.
If @racket[notify-frame?] is @racket[#t] then
@method[frame:searchable<%> search-hits-changed]
is called when the search completes.
} }
@defmethod[(set-search-anchor [position (or/c false/c number?)]) void?]{ @defmethod[(set-search-anchor [position (or/c false/c number?)]) void?]{
@ -374,7 +399,7 @@
@defmethod[(get-search-hit-count) number?]{ @defmethod[(get-search-hit-count) number?]{
Returns the number of hits for the search in the buffer, based on the count Returns the number of hits for the search in the buffer, based on the count
found last time that a search happened. found last time that a search completed.
} }
@defmethod[(get-replace-search-hit) (or/c number? #f)]{ @defmethod[(get-replace-search-hit) (or/c number? #f)]{
@ -578,8 +603,8 @@
(end exact-nonnegative-integer?) (end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(priority (symbols 'high 'low) 'low) (priority (or/c 'high 'low) 'low)
(style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle)) (style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
(-> void?)))]{ (-> void?)))]{
In addition to calling the super method, @method[text:basic<%> In addition to calling the super method, @method[text:basic<%>
highlight-range], this method forwards the highlighting to the delegatee. highlight-range], this method forwards the highlighting to the delegatee.
@ -591,7 +616,7 @@
(end exact-nonnegative-integer?) (end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) (style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
void?]{ void?]{
This method propagates the call to the delegate and calls the super method. This method propagates the call to the delegate and calls the super method.
} }

22
collects/tests/drracket/follow-log.rkt
View File

@ -36,10 +36,10 @@ log message was reported.
(define top-n-events 50) (define top-n-events 50)
(define drop-gc? #f) (define drop-gc? #f)
(define start-right-away? #f) ;; only applies if the 'main' module is loaded (define start-right-away? #t) ;; only applies if the 'main' module is loaded
(define show-hist? #t) (define show-hist? #t)
(define script-drr? #f) (define script-drr? #t)
(define interesting-range-start -inf.0) (define interesting-range-start 26)
(define interesting-range-end +inf.0) (define interesting-range-end +inf.0)
(define log-done-chan (make-channel)) (define log-done-chan (make-channel))
@ -219,7 +219,9 @@ log message was reported.
(printf "\nwith gc\n") (printf "\nwith gc\n")
(print-gui-event-hist has-gc-events) (print-gui-event-hist has-gc-events)
(printf "\nwithout gc\n") (printf "\nwithout gc\n")
(print-gui-event-hist no-gc-events)] (print-gui-event-hist no-gc-events)
(printf "\nboth with and without gc\n")
(print-gui-event-hist gui-events)]
[else [else
(define interesting-gui-events (define interesting-gui-events
(let ([candidate-events (let ([candidate-events
@ -338,15 +340,19 @@ log message was reported.
;(wait-until online-syncheck-done) ;(wait-until online-syncheck-done)
(for ([x (in-range 20)]) (for ([x (in-range 1)])
#;
(let ([s "fdjafjdklafjkdalsfjdaklfjdkaslfdjafjdklafjkdalsfjdaklfjdkasl"]) (let ([s "fdjafjdklafjkdalsfjdaklfjdkaslfdjafjdklafjkdalsfjdaklfjdkasl"])
(for ([c (in-string s)]) (for ([c (in-string s)])
(test:keystroke c)) (test:keystroke c)
;(test:keystroke #\return)
(sleep .3))
#;
(for ([c (in-string s)]) (for ([c (in-string s)])
(test:keystroke #\backspace)
(test:keystroke #\backspace))) (test:keystroke #\backspace)))
#;
(begin (begin
(test:keystroke #\") (test:keystroke #\")
(test:keystroke #\a) (test:keystroke #\a)

182
collects/tests/framework/search.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base)
(require "test-suite-utils.rkt") "test-suite-utils.rkt")
(define-syntax (test-search stx) (define-syntax (test-search stx)
(syntax-case stx () (syntax-case stx ()
@ -8,53 +8,159 @@
(with-syntax ([line (syntax-line stx)]) (with-syntax ([line (syntax-line stx)])
#'(test-search/proc line args ...))])) #'(test-search/proc line args ...))]))
(define (test-search/proc line txt string cs? rs bubble-table) ;; creates a search text, binds it to 't' and then,
;; for each expression in 'commands', evaluates it in a let
;; binding 't'. In between each call to commands, it waits
;; for the search text to quiesce and then finally gets
;; the search bubbles, comparing them to 'bubble-table'
(define (test-search/proc line commands bubble-table)
;(printf "running test on line ~s\n" line)
(test (test
(string->symbol (format "search.rkt: line ~a" line)) (string->symbol (format "search.rkt: line ~a pos immediately" line))
(lambda (x) (equal? bubble-table x)) (lambda (x) (equal? bubble-table x))
(lambda () (lambda ()
(queue-sexp-to-mred (send-sexp-to-mred
`(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))] `(let ([c (make-channel)])
[normalize (queue-callback
(λ (ht) (sort (hash-table-map ht list) (λ () (channel-put c (new (text:searching-mixin (editor:keymap-mixin text:basic%))))))
(λ (x y) (string<=? (format "~s" (car x)) (define t (channel-get c))
(format "~s" (car y))))))]) (define (wait)
(send t insert ,txt) (let loop ()
(send t set-searching-state ,string ,cs? ,rs) (queue-callback
(send t get-search-bubbles)))))) (λ ()
(channel-put c (send t search-updates-pending?)))
#f)
(when (channel-get c)
(loop))))
,@(apply
append
(for/list ([command (in-list commands)])
(list `(queue-callback (λ () ,command (channel-put c #f)))
'(channel-get c)
'(wait))))
(queue-callback
(λ ()
(channel-put c (send t get-search-bubbles)))
#f)
(channel-get c))))))
(define default-color "plum") (test-search (list '(begin (send t insert "")
(define light-color '(243 223 243)) (send t set-searching-state "aba" #t #f)
(define dark-color "mediumorchid") (send t set-position 0 0)))
'())
(test-search (list '(begin (send t insert "")
(send t set-searching-state "aba" #t #f))
'(send t set-position 0 0))
'())
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 3) normal-search-color)))
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #t #f) )
'(send t set-position 0 0))
`(((0 . 3) normal-search-color)))
(test-search "" "aba" #t #f '()) (test-search (list '(begin (send t insert "aba aba")
(test-search "aba" "aba" #t #f (send t set-searching-state "aba" #t #f)
`(((0 . 3) ,default-color))) (send t set-position 0 0)))
`(((0 . 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 . 7) normal-search-color)))
(test-search "aba aba" "aba" #t #f
`(((0 . 3) ,default-color)
((4 . 7) ,default-color)))
(test-search "abaaba" "aba" #t #f (test-search (list '(begin (send t insert "abaaba")
`(((0 . 6) ,default-color))) (send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 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 . 6) normal-search-color)))
(test-search "abababa" "aba" #t #f (test-search (list '(begin (send t insert "abababa")
`(((0 . 7) ,default-color))) (send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
`(((0 . 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 . 7) normal-search-color)))
(test-search "Aba" "aba" #t #f '()) (test-search (list '(begin (send t insert "Aba")
(test-search "Aba" "aba" #f #f `(((0 . 3) ,default-color))) (send t set-searching-state "aba" #t #f)
(send t set-position 0 0)))
'())
(test-search (list '(begin (send t insert "Aba")
(send t set-searching-state "aba" #t #f))
'(send t set-position 0 0))
'())
(test-search (list '(begin (send t insert "Aba")
(send t set-searching-state "aba" #f #f)
(send t set-position 0 0)))
`(((0 . 3) normal-search-color)))
(test-search (list '(begin (send t insert "Aba")
(send t set-searching-state "aba" #f #f))
'(send t set-position 0 0))
`(((0 . 3) normal-search-color)))
(test-search "" "aba" #t 0 '()) (test-search (list '(begin (send t set-searching-state "aba" #t 0)
(send t set-position 0)))
'())
(test-search "aba" "aba" #f 0 `(((0 . 3) ,dark-color))) (test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #f #t)
(send t set-position 0 0)))
`(((0 . 3) dark-search-color)))
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #f #t))
'(send t set-position 0 0))
`(((0 . 3) dark-search-color)))
(test-search "abababa" "aba" #f 0 (test-search (list '(begin (send t insert "abababa")
`(((0 . 7) ,light-color))) (send t set-searching-state "aba" #f #t)
(send t set-position 0 0)))
`(((0 . 3) dark-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 . 7) light-search-color)))
(test-search "aba aba aba" "aba" #f 2 (test-search (list '(begin (send t insert "aba aba aba")
`(((0 . 3) ,light-color) (send t set-searching-state "aba" #f #t)
((4 . 7) ,dark-color) (send t set-position 1 1)))
((8 . 11) ,light-color))) `(((0 . 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 . 7) dark-search-color)
((8 . 11) light-search-color)))
(test-search "abababa" "aba" #f 2 (test-search (list '(begin (send t insert "aba")
`(((0 . 7) ,light-color))) (send t set-searching-state "aba" #f #t))
'(send t set-position 0 0)
'(send t set-position 3 3))
`(((0 . 3) light-search-color)))
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #f #t))
'(send t set-position 0 0)
'(send t set-position 1 1))
`(((0 . 3) light-search-color)))
(test-search (list '(begin (send t insert "aba")
(send t set-searching-state "aba" #f #t))
'(send t set-searching-state #f #f #f))
`())

36
collects/tests/framework/test-suite-utils.rkt
View File

@ -86,18 +86,21 @@
(shutdown-mred) (shutdown-mred)
(thread (thread
(lambda () (lambda ()
(system* (define racket-bin
(path->string (path->string
(build-path (build-path
(let-values ([(dir exe _) (let-values ([(dir exe _)
(split-path (find-system-path 'exec-file))]) (split-path (find-system-path 'exec-file))])
(if (eq? dir 'relative) (if (eq? dir 'relative)
'same 'same
dir)) dir))
(if (eq? 'windows (system-type)) "Racket.exe" "racket"))) (if (eq? 'windows (system-type)) "Racket.exe" "racket"))))
(path->string (unless (system*
(build-path (collection-path "tests" "framework") racket-bin
"framework-test-engine.rkt"))))) (path->string
(build-path (collection-path "tests" "framework")
"framework-test-engine.rkt")))
(eprintf "starting gracket failed; used path ~s\n" racket-bin))))
(debug-printf mz-tcp "accepting listener\n") (debug-printf mz-tcp "accepting listener\n")
(let-values ([(in out) (tcp-accept listener)]) (let-values ([(in out) (tcp-accept listener)])
(set! in-port in) (set! in-port in)
@ -133,11 +136,10 @@
(set! in-port #f) (set! in-port #f)
(set! in-port #f)))) (set! in-port #f))))
(define mred-running? (define (mred-running?)
(lambda () (if (char-ready? in-port)
(if (char-ready? in-port) (not (eof-object? (peek-char in-port)))
(not (eof-object? (peek-char in-port))) #t))
#t)))
(define queue-sexp-to-mred (define queue-sexp-to-mred
(lambda (sexp) (lambda (sexp)