improve the interactivity of DrRacket's search
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
parent
0264d3d5ad
commit
5197649cb7
120
collects/framework/private/coroutine.rkt
Normal file
120
collects/framework/private/coroutine.rkt
Normal 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))
|
||||
|
||||
|
|
@ -40,7 +40,8 @@
|
|||
close
|
||||
get-filename/untitled-name
|
||||
|
||||
get-pos/text))
|
||||
get-pos/text
|
||||
get-pos/text-dc-location))
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor<%>) (basic<%>)
|
||||
|
|
|
|||
|
|
@ -1919,28 +1919,18 @@
|
|||
(send text-to-search set-search-anchor (send text-to-search get-start-position)))))))
|
||||
(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)
|
||||
(update-search/trigger-jump/later)
|
||||
(update-searching-str/trigger-jump)
|
||||
(inner (void) after-insert x y))
|
||||
(define/augment (after-delete x y)
|
||||
(update-search/trigger-jump/later)
|
||||
(update-searching-str/trigger-jump)
|
||||
(inner (void) after-delete x y))
|
||||
|
||||
(define/private (trigger-jump)
|
||||
(define/private (update-searching-str/trigger-jump)
|
||||
(let ([tlw (get-top-level-window)])
|
||||
(when tlw
|
||||
(send tlw search-string-changed)))
|
||||
|
||||
;; trigger-jump
|
||||
(when (preferences:get 'framework:anchored-search)
|
||||
(let ([frame (get-top-level-window)])
|
||||
(when frame
|
||||
|
|
@ -1953,6 +1943,7 @@
|
|||
(send text-to-search set-position anchor-pos anchor-pos)]
|
||||
[else
|
||||
(search 'forward #t #t #f anchor-pos)])))))))))
|
||||
|
||||
|
||||
(define/private (get-searching-text)
|
||||
(let ([frame (get-top-level-window)])
|
||||
|
|
@ -2062,12 +2053,6 @@
|
|||
(not-found found-edit #f))]
|
||||
[else
|
||||
(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?)
|
||||
(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 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:replace-on-demand item)
|
||||
(send item enable (and (not hidden?) replace-visible?)))
|
||||
|
|
@ -2278,12 +2263,13 @@
|
|||
(unless hidden?
|
||||
(when find-edit
|
||||
(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))
|
||||
(when new
|
||||
(send new set-search-anchor (send new get-start-position))
|
||||
(search-parameters-changed)))))))
|
||||
|
||||
;; called by the text-to-search when it finishes the search
|
||||
(define/public-final (search-hits-changed)
|
||||
(when find-edit
|
||||
(when text-to-search
|
||||
|
|
@ -2294,15 +2280,13 @@
|
|||
(send find-canvas set-red is-red?))))))
|
||||
|
||||
(define/public-final (search-string-changed) (search-parameters-changed))
|
||||
(define/public-final (search-text-changed) (search-parameters-changed))
|
||||
|
||||
(define/private (search-parameters-changed)
|
||||
(let ([str (send find-edit get-text)])
|
||||
(send text-to-search set-searching-state
|
||||
(if (equal? str "") #f str)
|
||||
case-sensitive-search?
|
||||
(and replace-visible? (send text-to-search get-start-position))))
|
||||
(search-hits-changed))
|
||||
replace-visible?
|
||||
#t)))
|
||||
|
||||
(define/public (search-hidden?) hidden?)
|
||||
|
||||
|
|
@ -2310,7 +2294,7 @@
|
|||
(set! hidden? #t)
|
||||
(when search-gui-built?
|
||||
(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
|
||||
(λ (l)
|
||||
(remove search/replace-panel l)))
|
||||
|
|
@ -2377,28 +2361,8 @@
|
|||
(send text-to-search set-position replacee-end 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)
|
||||
(let ([str (send find-edit get-text)])
|
||||
(send text-to-search set-searching-state
|
||||
(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))))))
|
||||
(search 'forward)
|
||||
(send text-to-search end-edit-sequence)))))))
|
||||
|
||||
(define/private (copy-over src-txt src-start src-end dest-txt dest-pos)
|
||||
(send src-txt split-snip src-start)
|
||||
|
|
@ -2491,135 +2455,133 @@
|
|||
(unless search-gui-built?
|
||||
(set! search-gui-built? #t)
|
||||
(begin-container-sequence)
|
||||
(let ()
|
||||
(define _-2 (set! find-edit (new find-text%)))
|
||||
(define _-1 (set! replace-edit (new replace-text%)))
|
||||
(define _0 (set! search/replace-panel (new horizontal-panel%
|
||||
[parent super-root]
|
||||
[stretchable-height #f])))
|
||||
(define search-panel
|
||||
(new horizontal-panel%
|
||||
[parent search/replace-panel]
|
||||
[stretchable-height #f]))
|
||||
(define replace-panel
|
||||
(new horizontal-panel%
|
||||
[parent search/replace-panel]
|
||||
[stretchable-height #f]))
|
||||
(define _1 (set! find-canvas (new searchable-canvas%
|
||||
[style '(hide-hscroll hide-vscroll)]
|
||||
[vertical-inset 2]
|
||||
[parent search-panel]
|
||||
[editor find-edit]
|
||||
[line-count 1]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #t])))
|
||||
|
||||
(define _3 (set! replace-canvas (new searchable-canvas%
|
||||
[style '(hide-hscroll hide-vscroll)]
|
||||
[vertical-inset 2]
|
||||
[parent replace-panel]
|
||||
[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)]
|
||||
(set! find-edit (new find-text%))
|
||||
(set! replace-edit (new replace-text%))
|
||||
(set! search/replace-panel (new horizontal-panel%
|
||||
[parent super-root]
|
||||
[stretchable-height #f]))
|
||||
(define search-panel
|
||||
(new horizontal-panel%
|
||||
[parent search/replace-panel]
|
||||
[stretchable-height #f]))
|
||||
(define replace-panel
|
||||
(new horizontal-panel%
|
||||
[parent search/replace-panel]
|
||||
[stretchable-height #f]))
|
||||
(set! find-canvas (new searchable-canvas%
|
||||
[style '(hide-hscroll hide-vscroll)]
|
||||
[vertical-inset 2]
|
||||
[parent search-panel]
|
||||
[editor find-edit]
|
||||
[line-count 1]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #t]))
|
||||
(set! replace-canvas (new searchable-canvas%
|
||||
[style '(hide-hscroll hide-vscroll)]
|
||||
[vertical-inset 2]
|
||||
[parent replace-panel]
|
||||
[editor replace-edit]
|
||||
[line-count 1]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #f]))
|
||||
|
||||
(define num-msg (new message%
|
||||
[label "0"]
|
||||
[vert-margin 0]
|
||||
[auto-resize #t]
|
||||
[font tiny-control-font]
|
||||
[parent hits-panel]))
|
||||
(define matches-msg (new message%
|
||||
[label (string-constant search-matches)]
|
||||
[stretchable-width #t]))
|
||||
|
||||
(define search-button (new button%
|
||||
[label (string-constant search-next)]
|
||||
[vert-margin 0]
|
||||
[font tiny-control-font]
|
||||
[parent hits-panel]))
|
||||
|
||||
(define _6 (set! update-matches
|
||||
(λ (before-caret-m m)
|
||||
(cond
|
||||
[(zero? m)
|
||||
(send num-msg set-label "0")]
|
||||
[else
|
||||
(let ([number (number->str/comma m)]
|
||||
[bc-number (number->str/comma before-caret-m)])
|
||||
(send num-msg set-label (format "~a/~a" bc-number number)))])
|
||||
(send matches-msg set-label (if (= m 1)
|
||||
(string-constant search-match)
|
||||
(string-constant search-matches))))))
|
||||
|
||||
(define replace-button
|
||||
(new button%
|
||||
[label (string-constant search-replace)]
|
||||
[vert-margin 0]
|
||||
[parent replace-panel]
|
||||
[font small-control-font]
|
||||
[callback (λ (x y) (search-replace))]))
|
||||
(define skip-button
|
||||
(new button%
|
||||
[label (string-constant search-skip)]
|
||||
[vert-margin 0]
|
||||
[parent replace-panel]
|
||||
[font small-control-font]
|
||||
[callback (λ (x y) (search 'forward))]))
|
||||
|
||||
(define show-replace-button
|
||||
(new button%
|
||||
[label (string-constant search-show-replace)]
|
||||
[font small-control-font]
|
||||
[callback (λ (a b) (set-replace-visible? #t))]
|
||||
[parent replace-panel]))
|
||||
(define hide-replace-button
|
||||
(new button%
|
||||
[label (string-constant search-hide-replace)]
|
||||
[font small-control-font]
|
||||
[callback (λ (a b) (set-replace-visible? #f))]
|
||||
[parent replace-panel]))
|
||||
|
||||
(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))
|
||||
[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-width #f]))
|
||||
|
||||
(define num-msg (new message%
|
||||
[label "0"]
|
||||
[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]
|
||||
[font tiny-control-font]
|
||||
[parent hits-panel]))
|
||||
|
||||
(define _6 (set! update-matches
|
||||
(λ (before-caret-m m)
|
||||
(cond
|
||||
[(zero? m)
|
||||
(send num-msg set-label "0")]
|
||||
[else
|
||||
(let ([number (number->str/comma m)]
|
||||
[bc-number (number->str/comma before-caret-m)])
|
||||
(send num-msg set-label (format "~a/~a" bc-number number)))])
|
||||
(send matches-msg set-label (if (= m 1)
|
||||
(string-constant search-match)
|
||||
(string-constant search-matches))))))
|
||||
|
||||
(define replace-button
|
||||
(new button%
|
||||
[label (string-constant search-replace)]
|
||||
[vert-margin 0]
|
||||
[parent replace-panel]
|
||||
[font small-control-font]
|
||||
[callback (λ (x y) (search-replace))]))
|
||||
(define skip-button
|
||||
(new button%
|
||||
[label (string-constant search-skip)]
|
||||
[vert-margin 0]
|
||||
[parent replace-panel]
|
||||
[font small-control-font]
|
||||
[callback (λ (x y) (search 'forward))]))
|
||||
|
||||
(define show-replace-button
|
||||
(new button%
|
||||
[label (string-constant search-show-replace)]
|
||||
[font small-control-font]
|
||||
[callback (λ (a b) (set-replace-visible? #t))]
|
||||
[parent replace-panel]))
|
||||
(define hide-replace-button
|
||||
(new button%
|
||||
[label (string-constant search-hide-replace)]
|
||||
[font small-control-font]
|
||||
[callback (λ (a b) (set-replace-visible? #f))]
|
||||
[parent replace-panel]))
|
||||
|
||||
(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)))
|
||||
|
||||
(super-new)))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -11,8 +11,8 @@
|
|||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(priority (symbols 'high 'low) 'low)
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
|
||||
(priority (or/c 'high 'low) 'low)
|
||||
(style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
|
||||
(-> void?)))]{
|
||||
This function highlights a region of text in the buffer.
|
||||
|
||||
|
|
@ -46,16 +46,33 @@
|
|||
}
|
||||
|
||||
@defmethod[(unhighlight-range
|
||||
(start exact-nonnegative-integer?)
|
||||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
|
||||
void?]{
|
||||
(start exact-nonnegative-integer?)
|
||||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
|
||||
void?]{
|
||||
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
|
||||
@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?)))]{
|
||||
|
|
@ -353,11 +370,12 @@
|
|||
|
||||
@defmethod[(set-searching-state [str (or/c false/c string?)]
|
||||
[cs? boolean?]
|
||||
[replace-start (or/c false/c number?)])
|
||||
[replace-start (or/c false/c number?)]
|
||||
[notify-frame? boolean?])
|
||||
void?]{
|
||||
If @racket[str] is not @racket[#f], then this method highlights every
|
||||
occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f],
|
||||
then it clears all of the highlighting in the buffer.
|
||||
If @racket[str] is not @racket[#f], then this method initiates a search for
|
||||
every occurrence of @racket[str] in the editor. If @racket[str] is @racket[#f],
|
||||
then it clears all of the search highlighting in the buffer.
|
||||
|
||||
If @racket[cs?] is @racket[#f], the search is case-insensitive, and otherwise
|
||||
it is case-sensitive.
|
||||
|
|
@ -365,6 +383,13 @@
|
|||
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
|
||||
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?]{
|
||||
|
|
@ -374,7 +399,7 @@
|
|||
|
||||
@defmethod[(get-search-hit-count) number?]{
|
||||
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)]{
|
||||
|
|
@ -578,8 +603,8 @@
|
|||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(priority (symbols 'high 'low) 'low)
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
|
||||
(priority (or/c 'high 'low) 'low)
|
||||
(style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
|
||||
(-> void?)))]{
|
||||
In addition to calling the super method, @method[text:basic<%>
|
||||
highlight-range], this method forwards the highlighting to the delegatee.
|
||||
|
|
@ -591,7 +616,7 @@
|
|||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
|
||||
(style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
|
||||
void?]{
|
||||
This method propagates the call to the delegate and calls the super method.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -36,10 +36,10 @@ log message was reported.
|
|||
|
||||
(define top-n-events 50)
|
||||
(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 script-drr? #f)
|
||||
(define interesting-range-start -inf.0)
|
||||
(define script-drr? #t)
|
||||
(define interesting-range-start 26)
|
||||
(define interesting-range-end +inf.0)
|
||||
|
||||
(define log-done-chan (make-channel))
|
||||
|
|
@ -219,7 +219,9 @@ log message was reported.
|
|||
(printf "\nwith gc\n")
|
||||
(print-gui-event-hist has-gc-events)
|
||||
(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
|
||||
(define interesting-gui-events
|
||||
(let ([candidate-events
|
||||
|
|
@ -338,15 +340,19 @@ log message was reported.
|
|||
|
||||
;(wait-until online-syncheck-done)
|
||||
|
||||
(for ([x (in-range 20)])
|
||||
(for ([x (in-range 1)])
|
||||
|
||||
|
||||
#;
|
||||
(let ([s "fdjafjdklafjkdalsfjdaklfjdkaslfdjafjdklafjkdalsfjdaklfjdkasl"])
|
||||
(for ([c (in-string s)])
|
||||
(test:keystroke c))
|
||||
(test:keystroke c)
|
||||
;(test:keystroke #\return)
|
||||
(sleep .3))
|
||||
#;
|
||||
(for ([c (in-string s)])
|
||||
(test:keystroke #\backspace)
|
||||
(test:keystroke #\backspace)))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(test:keystroke #\")
|
||||
(test:keystroke #\a)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
(require "test-suite-utils.rkt")
|
||||
(require (for-syntax racket/base)
|
||||
"test-suite-utils.rkt")
|
||||
|
||||
(define-syntax (test-search stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -8,53 +8,159 @@
|
|||
(with-syntax ([line (syntax-line stx)])
|
||||
#'(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
|
||||
(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 ()
|
||||
(queue-sexp-to-mred
|
||||
`(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))]
|
||||
[normalize
|
||||
(λ (ht) (sort (hash-table-map ht list)
|
||||
(λ (x y) (string<=? (format "~s" (car x))
|
||||
(format "~s" (car y))))))])
|
||||
(send t insert ,txt)
|
||||
(send t set-searching-state ,string ,cs? ,rs)
|
||||
(send t get-search-bubbles))))))
|
||||
(send-sexp-to-mred
|
||||
`(let ([c (make-channel)])
|
||||
(queue-callback
|
||||
(λ () (channel-put c (new (text:searching-mixin (editor:keymap-mixin text:basic%))))))
|
||||
(define t (channel-get c))
|
||||
(define (wait)
|
||||
(let loop ()
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(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")
|
||||
(define light-color '(243 223 243))
|
||||
(define dark-color "mediumorchid")
|
||||
(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 "")
|
||||
(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 "aba" "aba" #t #f
|
||||
`(((0 . 3) ,default-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 (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
|
||||
`(((0 . 6) ,default-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 (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
|
||||
`(((0 . 7) ,default-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 (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 "Aba" "aba" #f #f `(((0 . 3) ,default-color)))
|
||||
(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" #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
|
||||
`(((0 . 7) ,light-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 (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
|
||||
`(((0 . 3) ,light-color)
|
||||
((4 . 7) ,dark-color)
|
||||
((8 . 11) ,light-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 (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
|
||||
`(((0 . 7) ,light-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 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))
|
||||
`())
|
||||
|
|
|
|||
|
|
@ -86,18 +86,21 @@
|
|||
(shutdown-mred)
|
||||
(thread
|
||||
(lambda ()
|
||||
(system*
|
||||
(path->string
|
||||
(build-path
|
||||
(let-values ([(dir exe _)
|
||||
(split-path (find-system-path 'exec-file))])
|
||||
(if (eq? dir 'relative)
|
||||
'same
|
||||
dir))
|
||||
(if (eq? 'windows (system-type)) "Racket.exe" "racket")))
|
||||
(path->string
|
||||
(build-path (collection-path "tests" "framework")
|
||||
"framework-test-engine.rkt")))))
|
||||
(define racket-bin
|
||||
(path->string
|
||||
(build-path
|
||||
(let-values ([(dir exe _)
|
||||
(split-path (find-system-path 'exec-file))])
|
||||
(if (eq? dir 'relative)
|
||||
'same
|
||||
dir))
|
||||
(if (eq? 'windows (system-type)) "Racket.exe" "racket"))))
|
||||
(unless (system*
|
||||
racket-bin
|
||||
(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")
|
||||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
|
|
@ -133,11 +136,10 @@
|
|||
(set! in-port #f)
|
||||
(set! in-port #f))))
|
||||
|
||||
(define mred-running?
|
||||
(lambda ()
|
||||
(if (char-ready? in-port)
|
||||
(not (eof-object? (peek-char in-port)))
|
||||
#t)))
|
||||
(define (mred-running?)
|
||||
(if (char-ready? in-port)
|
||||
(not (eof-object? (peek-char in-port)))
|
||||
#t))
|
||||
|
||||
(define queue-sexp-to-mred
|
||||
(lambda (sexp)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user